home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2007 September / PCWSEP07.iso / Software / Linux / Linux Mint 3.0 Light / LinuxMint-3.0-Light.iso / casper / filesystem.squashfs / usr / share / perl5 / XML / Twig.pm < prev   
Encoding:
Text File  |  2006-11-22  |  395.5 KB  |  12,418 lines

  1. # $Id: Twig_pm.slow,v 1.303 2006/05/26 08:07:14 mrodrigu Exp $
  2. #
  3. # Copyright (c) 1999-2004 Michel Rodriguez
  4. # All rights reserved.
  5. #
  6. # This program is free software; you can redistribute it and/or
  7. # modify it under the same terms as Perl itself.
  8. #
  9.  
  10. # This is created in the caller's space
  11. BEGIN
  12. { sub ::PCDATA { '#PCDATA' } 
  13.   sub ::CDATA  { '#CDATA'  } 
  14. }
  15.  
  16.  
  17. ######################################################################
  18. package XML::Twig;
  19. ######################################################################
  20.  
  21. require 5.004;
  22. use strict; 
  23.  
  24. use vars qw($VERSION @ISA %valid_option);
  25. use Carp;
  26.  
  27. *isa = \&UNIVERSAL::isa;
  28.  
  29. #start-extract twig_global
  30.  
  31. # constants: element types
  32. use constant (PCDATA  => '#PCDATA');
  33. use constant (CDATA   => '#CDATA');
  34. use constant (PI      => '#PI');
  35. use constant (COMMENT => '#COMMENT');
  36. use constant (ENT     => '#ENT');
  37.  
  38. # element classes
  39. use constant (ELT     => '#ELT');
  40. use constant (TEXT    => '#TEXT');
  41.  
  42. # element properties
  43. use constant (ASIS    => '#ASIS');
  44. use constant (EMPTY   => '#EMPTY');
  45.  
  46. #end-extract twig_global
  47.  
  48. # used in parseurl to set the buffer size to the same size as in XML::Parser::Expat
  49. use constant (BUFSIZE => 32768);
  50.  
  51.  
  52. # used to store the gi's
  53. my %gi2index;   # gi => index
  54. my @index2gi;   # list of gi's
  55. my $SPECIAL_GI; # first non-special gi;
  56. my %base_ent;   # base entity character => replacement
  57.  
  58. # flag, set to true if the weaken sub is available
  59. use vars qw( $weakrefs);
  60.  
  61. #start-extract twig_global
  62. my $REG_NAME       = q{(?:(?:[^\W\d]|[:#])(?:[\w.-]*:)?[\w.-]*)};     # xml name
  63. my $REG_NAME_W     = q{(?:(?:[^\W\d_]|[:#])(?:[\w.-]*:)?[\w.-]*|\*)}; # name or wildcard (* or '')
  64. my $REG_REGEXP     = q{(?:/(?:[^\\/]|\\.)*/[eimsox]*)};               # regexp
  65. my $REG_REGEXP_EXP = q{(?:(?:[^\\/]|\\.)*)};                          # content of a regexp
  66. my $REG_REGEXP_MOD = q{(?:[eimso]*)};                                 # regexp modifiers
  67. my $REG_MATCH      = q{[!=]~};                                        # match (or not)
  68. my $REG_STRING     = q{(?:"(?:[^\\"]|\\.)*"|'(?:[^\\']|\\.)*')};      # string (simple or double quoted)
  69. my $REG_NUMBER     = q{(?:\d+(?:\.\d*)?|\.\d+)};                      # number
  70. my $REG_VALUE      = qq{(?:$REG_STRING|$REG_NUMBER)};                 # value
  71. my $REG_OP         = q{=|==|!=|>|<|>=|<=|eq|ne|lt|gt|le|ge};          # op
  72.  
  73. # not all axis, only supported ones (in get_xpath)
  74. my @supported_axis= ( 'ancestor', 'ancestor-or-self', 'child', 'descendant', 'descendant-or-self', 
  75.                       'following', 'following-sibling', 'parent', 'preceding', 'preceding-sibling', 'self'
  76.                     );
  77. my $REG_AXIS       = "(?:" . join( '|', @supported_axis) .")";
  78.  
  79. # only used in the "xpath"engine (for get_xpath/findnodes) for now
  80. my $REG_PREDICATE  = qr{\[(?:(?:string\(\s*\)|\@$REG_NAME)\s*$REG_MATCH\s*$REG_REGEXP\s*|[^\]]*)\]};
  81.  
  82.  
  83. #end-extract twig_global
  84.  
  85. my $parser_version;
  86. my( $FB_HTMLCREF, $FB_XMLCREF);
  87.  
  88.  
  89. BEGIN
  90. $VERSION = '3.26';
  91.  
  92. use XML::Parser;
  93. my $needVersion = '2.23';
  94. $parser_version= $XML::Parser::VERSION;
  95. croak "need at least XML::Parser version $needVersion" unless $parser_version >= $needVersion;
  96.  
  97. if( $] >= 5.008) 
  98.   { eval "use Encode qw( :all)";
  99.     $FB_XMLCREF  = 0x0400; # Encode::FB_XMLCREF;
  100.     $FB_HTMLCREF = 0x0200; # Encode::FB_HTMLCREF;
  101.   }
  102.  
  103. # test whether we can use weak references
  104. # set local empty signal handler to trap error messages
  105. { local $SIG{__DIE__};
  106.   if( eval( 'require Scalar::Util') && defined( &Scalar::Util::weaken) ) 
  107.     { import Scalar::Util( 'weaken'); $weakrefs= 1; }
  108.   elsif( eval( 'require WeakRef')) 
  109.     { import WeakRef; $weakrefs= 1;                 }
  110.   else  
  111.     { $weakrefs= 0;                                 } 
  112. }
  113.  
  114. import XML::Twig::Elt;
  115. import XML::Twig::Entity;
  116. import XML::Twig::Entity_list;
  117.  
  118. # used to store the gi's
  119. # should be set for each twig really, at least when there are several
  120. # the init ensures that special gi's are always the same
  121.  
  122. # gi => index
  123. # do NOT use => or the constants become quoted!
  124. %XML::Twig::gi2index=( PCDATA, 0, CDATA, 1, PI, 2, COMMENT, 3, ENT, 4); 
  125. # list of gi's
  126. @XML::Twig::index2gi=( PCDATA, CDATA, PI, COMMENT, ENT);
  127.  
  128. # gi's under this value are special 
  129. $XML::Twig::SPECIAL_GI= @XML::Twig::index2gi;
  130.  
  131. %XML::Twig::base_ent= ( '>' => '>', '<' => '<', '&' => '&', "'" => ''', '"' => '"',);
  132.  
  133. # now set some aliases
  134. *find_nodes           = *get_xpath;               # same as XML::XPath
  135. *findnodes            = *get_xpath;               # same as XML::LibXML
  136. *getElementsByTagName = *descendants;
  137. *descendants_or_self  = *descendants;             # valid in XML::Twig, not in XML::Twig::Elt
  138. *find_by_tag_name     = *descendants;
  139. *getElementById       = *elt_id;
  140. *getEltById           = *elt_id;
  141. *toString             = *sprint;
  142. }
  143.  
  144. @ISA = qw(XML::Parser);
  145.  
  146. # fake gi's used in twig_handlers and start_tag_handlers
  147. my $ALL    = '_all_';     # the associated function is always called
  148. my $DEFAULT= '_default_'; # the function is called if no other handler has been
  149.  
  150. # some defaults
  151. my $COMMENTS_DEFAULT= 'keep';
  152. my $PI_DEFAULT      = 'keep';
  153.  
  154.  
  155. # handlers used in regular mode
  156. my %twig_handlers=( Start      => \&_twig_start, 
  157.                     End        => \&_twig_end, 
  158.                     Char       => \&_twig_char, 
  159.                     Entity     => \&_twig_entity, 
  160.                     XMLDecl    => \&_twig_xmldecl, 
  161.                     Doctype    => \&_twig_doctype, 
  162.                     Element    => \&_twig_element, 
  163.                     Attlist    => \&_twig_attlist, 
  164.                     CdataStart => \&_twig_cdatastart, 
  165.                     CdataEnd   => \&_twig_cdataend, 
  166.                     Proc       => \&_twig_pi,
  167.                     Comment    => \&_twig_comment,
  168.                     Default    => \&_twig_default,
  169.       );
  170.  
  171. # handlers used when twig_roots is used and we are outside of the roots
  172. my %twig_handlers_roots=
  173.   ( Start      => \&_twig_start_check_roots, 
  174.     End        => \&_twig_end_check_roots, 
  175.     Doctype    => \&_twig_doctype, 
  176.     Char       => undef, Entity     => undef, XMLDecl    => \&_twig_xmldecl, 
  177.     Element    => undef, Attlist    => undef, CdataStart => undef, 
  178.     CdataEnd   => undef, Proc       => undef, Comment    => undef, 
  179.     Proc       => \&_twig_pi_check_roots,
  180.     Default    =>  sub {}, # hack needed for XML::Parser 2.27
  181.   );
  182.  
  183. # handlers used when twig_roots and print_outside_roots are used and we are
  184. # outside of the roots
  185. my %twig_handlers_roots_print_2_30=
  186.   ( Start      => \&_twig_start_check_roots, 
  187.     End        => \&_twig_end_check_roots, 
  188.     Char       => \&_twig_print, 
  189.     # I have no idea why I should not be using this handler!
  190.     Entity     => \&_twig_print_entity, 
  191.     XMLDecl    => \&_twig_print,
  192.     Doctype   =>  \&_twig_print_doctype, # because recognized_string is broken here
  193.     # Element    => \&_twig_print, Attlist    => \&_twig_print, 
  194.     CdataStart => \&_twig_print, CdataEnd   => \&_twig_print, 
  195.     Proc       => \&_twig_pi_check_roots, Comment    => \&_twig_print, 
  196.     Default    => \&_twig_print_check_doctype,
  197.   );
  198.  
  199. # handlers used when twig_roots, print_outside_roots and keep_encoding are used
  200. # and we are outside of the roots
  201. my %twig_handlers_roots_print_original_2_30=
  202.   ( Start      => \&_twig_start_check_roots, 
  203.     End        => \&_twig_end_check_roots, 
  204.     Char       => \&_twig_print_original, 
  205.     # I have no idea why I should not be using this handler!
  206.     #Entity     => \&_twig_print_original, 
  207.     ExternEnt  => \&_twig_print_entity,
  208.     XMLDecl    => \&_twig_print_original, 
  209.     Doctype    => \&_twig_print_original_doctype,  # because original_string is broken here
  210.     Element    => \&_twig_print_original, Attlist   => \&_twig_print_original,
  211.     CdataStart => \&_twig_print_original, CdataEnd  => \&_twig_print_original,
  212.     Proc       => \&_twig_pi_check_roots, Comment   => \&_twig_print_original,
  213.     Default    => \&_twig_print_original_check_doctype, 
  214.   );
  215.  
  216. # handlers used when twig_roots and print_outside_roots are used and we are
  217. # outside of the roots
  218. my %twig_handlers_roots_print_2_27=
  219.   ( Start      => \&_twig_start_check_roots, 
  220.     End        => \&_twig_end_check_roots, 
  221.     Char       => \&_twig_print, 
  222.     # I have no idea why I should not be using this handler!
  223.     #Entity     => \&_twig_print, 
  224.     XMLDecl    => \&_twig_print, Doctype    => \&_twig_print, 
  225.     CdataStart => \&_twig_print, CdataEnd   => \&_twig_print, 
  226.     Proc       => \&_twig_pi_check_roots, Comment    => \&_twig_print, 
  227.     Default    => \&_twig_print, 
  228.   );
  229.  
  230. # handlers used when twig_roots, print_outside_roots and keep_encoding are used
  231. # and we are outside of the roots
  232. my %twig_handlers_roots_print_original_2_27=
  233.   ( Start      => \&_twig_start_check_roots, 
  234.     End        => \&_twig_end_check_roots, 
  235.     Char       => \&_twig_print_original, 
  236.     # for some reason original_string is wrong here 
  237.     # this can be a problem if the doctype includes non ascii characters
  238.     XMLDecl    => \&_twig_print, Doctype    => \&_twig_print,
  239.     # I have no idea why I should not be using this handler!
  240.     Entity     => \&_twig_print, 
  241.     #Element    => undef, Attlist   => undef,
  242.     CdataStart => \&_twig_print_original, CdataEnd  => \&_twig_print_original,
  243.     Proc       => \&_twig_pi_check_roots, Comment   => \&_twig_print_original,
  244.     Default    => \&_twig_print, #  _twig_print_original does not work
  245.   );
  246.  
  247.  
  248. my %twig_handlers_roots_print= $parser_version > 2.27 
  249.                                ? %twig_handlers_roots_print_2_30 
  250.                                : %twig_handlers_roots_print_2_27; 
  251. my %twig_handlers_roots_print_original= $parser_version > 2.27 
  252.                                ? %twig_handlers_roots_print_original_2_30 
  253.                                : %twig_handlers_roots_print_original_2_27; 
  254.  
  255.  
  256. # handlers used when the finish_print method has been called
  257. my %twig_handlers_finish_print=
  258.   ( Start      => \&_twig_print, 
  259.     End        => \&_twig_print, Char       => \&_twig_print, 
  260.     Entity     => \&_twig_print, XMLDecl    => \&_twig_print, 
  261.     Doctype    => \&_twig_print, Element    => \&_twig_print, 
  262.     Attlist    => \&_twig_print, CdataStart => \&_twig_print, 
  263.     CdataEnd   => \&_twig_print, Proc       => \&_twig_print, 
  264.     Comment    => \&_twig_print, Default    => \&_twig_print, 
  265.   );
  266.  
  267. # handlers used when the finish_print method has been called and the keep_encoding
  268. # option is used
  269. my %twig_handlers_finish_print_original=
  270.   ( Start      => \&_twig_print_original, End      => \&_twig_print_end_original, 
  271.     Char       => \&_twig_print_original, Entity   => \&_twig_print_original, 
  272.     XMLDecl    => \&_twig_print_original, Doctype  => \&_twig_print_original, 
  273.     Element    => \&_twig_print_original, Attlist  => \&_twig_print_original, 
  274.     CdataStart => \&_twig_print_original, CdataEnd => \&_twig_print_original, 
  275.     Proc       => \&_twig_print_original, Comment  => \&_twig_print_original, 
  276.     Default    => \&_twig_print_original, 
  277.   );
  278.  
  279. # handlers used whithin ignored elements
  280. my %twig_handlers_ignore=
  281.   ( Start      => \&_twig_ignore_start, 
  282.     End        => \&_twig_ignore_end, 
  283.     Char       => undef, Entity     => undef, XMLDecl    => undef, 
  284.     Doctype    => undef, Element    => undef, Attlist    => undef, 
  285.     CdataStart => undef, CdataEnd   => undef, Proc       => undef, 
  286.     Comment    => undef, Default    => undef,
  287.   );
  288.  
  289.  
  290. # those handlers are only used if the entities are NOT to be expanded
  291. my %twig_noexpand_handlers= ( Default => \&_twig_default );
  292.  
  293. my @saved_default_handler;
  294.  
  295. my $ID= 'id'; # default value, set by the Id argument
  296.  
  297. # all allowed options
  298. %valid_option=
  299.     ( # XML::Twig options
  300.       TwigHandlers          => 1, Id                    => 1,
  301.       TwigRoots             => 1, TwigPrintOutsideRoots => 1,
  302.       StartTagHandlers      => 1, EndTagHandlers        => 1,
  303.       ForceEndTagHandlersUsage => 1,
  304.       DoNotChainHandlers    => 1,
  305.       IgnoreElts            => 1,
  306.       Index                 => 1,
  307.       CharHandler           => 1, 
  308.       KeepEncoding          => 1, DoNotEscapeAmpInAtts  => 1,
  309.       ParseStartTag         => 1, KeepAttsOrder         => 1,
  310.       LoadDTD               => 1, DTDHandler            => 1,
  311.       DoNotOutputDTD        => 1, NoProlog              => 1,
  312.       ExpandExternalEnts    => 1,
  313.       DiscardSpaces         => 1, KeepSpaces            => 1, 
  314.       DiscardSpacesIn       => 1, KeepSpacesIn          => 1, 
  315.       PrettyPrint           => 1, EmptyTags             => 1, 
  316.       Comments              => 1, Pi                    => 1, 
  317.       OutputFilter          => 1, InputFilter           => 1,
  318.       OutputTextFilter      => 1, 
  319.       OutputEncoding        => 1, 
  320.       RemoveCdata           => 1,
  321.       EltClass              => 1,
  322.       MapXmlns              => 1, KeepOriginalPrefix    => 1,
  323.       # XML::Parser options
  324.       ErrorContext          => 1, ProtocolEncoding      => 1,
  325.       Namespaces            => 1, NoExpand              => 1,
  326.       Stream_Delimiter      => 1, ParseParamEnt         => 1,
  327.       NoLWP                 => 1, Non_Expat_Options     => 1,
  328.       Xmlns                 => 1,
  329.     );
  330.  
  331. # predefined input and output filters
  332. use vars qw( %filter);
  333. %filter= ( html       => \&html_encode,
  334.            safe       => \&safe_encode,
  335.            safe_hex   => \&safe_encode_hex,
  336.          );
  337. 1;
  338. sub new
  339.   { my ($class, %args) = @_;
  340.     my $handlers;
  341.  
  342.     # change all nice_perlish_names into nicePerlishNames
  343.     %args= _normalize_args( %args);
  344.  
  345.     # check options
  346.     unless( $args{MoreOptions})
  347.       { foreach my $arg (keys %args)
  348.         { carp "invalid option $arg" unless $valid_option{$arg}; }
  349.       }
  350.      
  351.     # a twig is really an XML::Parser
  352.     # my $self= XML::Parser->new(%args);
  353.     my $self;
  354.     $self= XML::Parser->new(%args);   
  355.     
  356.     bless $self, $class;
  357.  
  358.     if( exists $args{TwigHandlers})
  359.       { $handlers= $args{TwigHandlers};
  360.         $self->setTwigHandlers( $handlers);
  361.         delete $args{TwigHandlers};
  362.       }
  363.  
  364.     # take care of twig-specific arguments
  365.     if( exists $args{StartTagHandlers})
  366.       { $self->setStartTagHandlers( $args{StartTagHandlers});
  367.         delete $args{StartTagHandlers};
  368.       }
  369.  
  370.     if( exists $args{DoNotChainHandlers})
  371.       { $self->{twig_do_not_chain_handlers}=  $args{DoNotChainHandlers}; }
  372.  
  373.     if( exists $args{IgnoreElts})
  374.       { $self->setIgnoreEltsHandlers( $args{IgnoreElts});
  375.         delete $args{IgnoreElts};
  376.       }
  377.  
  378.     if( exists $args{Index})
  379.       { my $index= $args{Index};
  380.         # we really want a hash name => path, we turn an array into a hash if necessary
  381.         if( ref( $index) eq 'ARRAY')
  382.           { my %index= map { $_ => $_ } @$index;
  383.             $index= \%index;
  384.           }
  385.         while( my( $name, $exp)= each %$index)
  386.           { $self->setTwigHandler( $exp, sub { push @{$_[0]->{_twig_index}->{$name}}, $_; 1; }); }
  387.       }
  388.  
  389.     $self->{twig_elt_class}= $args{EltClass} || 'XML::Twig::Elt';
  390.     if( exists( $args{EltClass})) { delete $args{EltClass}; }
  391.  
  392.     if( exists( $args{MapXmlns}))
  393.       { $self->{twig_map_xmlns}=  $args{MapXmlns};
  394.         $self->{Namespaces}=1;
  395.         delete $args{MapXmlns};
  396.       }
  397.  
  398.     if( exists( $args{KeepOriginalPrefix}))
  399.       { $self->{twig_keep_original_prefix}= $args{KeepOriginalPrefix};
  400.         delete $args{KeepOriginalPrefix};
  401.       }
  402.  
  403.     $self->{twig_dtd_handler}= $args{DTDHandler};
  404.     delete $args{DTDHandler};
  405.  
  406.     if( $args{CharHandler})
  407.       { $self->setCharHandler( $args{CharHandler});
  408.         delete $args{CharHandler};
  409.       }
  410.  
  411.     if( $args{LoadDTD})
  412.       { $self->{twig_read_external_dtd}= 1;
  413.         delete $args{LoadDTD};
  414.       }
  415.       
  416.     if( $args{ExpandExternalEnts})
  417.       { $self->set_expand_external_entities( 1);
  418.         $self->{twig_read_external_dtd}= 1; # implied by ExpandExternalEnts
  419.         delete $args{LoadDTD};
  420.         delete $args{ExpandExternalEnts};
  421.       }
  422.  
  423.     if( $args{DoNotEscapeAmpInAtts})
  424.       { $self->set_do_not_escape_amp_in_atts( 1); 
  425.         $self->{twig_do_not_escape_amp_in_atts}=1;
  426.       }
  427.     else
  428.       { $self->set_do_not_escape_amp_in_atts( 0); 
  429.         $self->{twig_do_not_escape_amp_in_atts}=0;
  430.       }
  431.  
  432.     # deal with TwigRoots argument, a hash of elements for which
  433.     # subtrees will be built (and associated handlers)
  434.      
  435.     if( $args{TwigRoots})
  436.       { $self->setTwigRoots( $args{TwigRoots});
  437.         delete $args{TwigRoots}; 
  438.       }
  439.     
  440.     if( $args{EndTagHandlers})
  441.       { unless ($self->{twig_roots} || $args{ForceEndTagHandlersUsage})
  442.           { croak "you should not use EndTagHandlers without TwigRoots\n",
  443.                   "if you want to use it anyway, normally because you have ",
  444.                   "a start_tag_handlers that calls 'ignore' and you want to ",
  445.                   "call an ent_tag_handlers at the end of the element, then ",
  446.                   "pass 'force_end_tag_handlers_usage => 1' as an argument ",
  447.                   "to new";
  448.           }
  449.                   
  450.         $self->setEndTagHandlers( $args{EndTagHandlers});
  451.         delete $args{EndTagHandlers};
  452.       }
  453.       
  454.     if( $args{TwigPrintOutsideRoots})
  455.       { croak "cannot use TwigPrintOutsideRoots without TwigRoots"
  456.           unless( $self->{twig_roots});
  457.         # if the arg is a filehandle then store it
  458.         if( _is_fh( $args{TwigPrintOutsideRoots}) )
  459.           { $self->{twig_output_fh}= $args{TwigPrintOutsideRoots}; }
  460.         $self->{twig_default_print}= $args{TwigPrintOutsideRoots};
  461.       }
  462.  
  463.     if( $args{PrettyPrint})
  464.       { $self->set_pretty_print( $args{PrettyPrint}); }
  465.  
  466.     if( $args{EmptyTags})
  467.       { $self->set_empty_tag_style( $args{EmptyTags}); }
  468.  
  469.     # space policy
  470.     if( $args{KeepSpaces})
  471.       { croak "cannot use both keep_spaces and discard_spaces" if( $args{DiscardSpaces});
  472.         croak "cannot use both keep_spaces and keep_spaces_in" if( $args{KeepSpacesIn});
  473.         $self->{twig_keep_spaces}=1;
  474.         delete $args{KeepSpaces}; 
  475.       }
  476.     if( $args{DiscardSpaces})
  477.       { croak "cannot use both discard_spaces and keep_spaces_in" if( $args{KeepSpacesIn});
  478.         $self->{twig_discard_spaces}=1; 
  479.         delete $args{DiscardSpaces}; 
  480.       }
  481.     if( $args{KeepSpacesIn})
  482.       { croak "cannot use both keep_spaces_in and discard_spaces_in" if( $args{DiscardSpacesIn});
  483.         $self->{twig_discard_spaces}=1; 
  484.         $self->{twig_keep_spaces_in}={}; 
  485.         my @tags= @{$args{KeepSpacesIn}}; 
  486.         foreach my $tag (@tags) { $self->{twig_keep_spaces_in}->{$tag}=1; } 
  487.         delete $args{KeepSpacesIn}; 
  488.       }
  489.     if( $args{DiscardSpacesIn})
  490.       { $self->{twig_keep_spaces}=1; 
  491.         $self->{twig_discard_spaces_in}={}; 
  492.         my @tags= @{$args{DiscardSpacesIn}};
  493.         foreach my $tag (@tags) { $self->{twig_discard_spaces_in}->{$tag}=1; } 
  494.         delete $args{DiscardSpacesIn}; 
  495.       }
  496.     # discard spaces by default 
  497.     $self->{twig_discard_spaces}= 1 unless(  $self->{twig_keep_spaces});
  498.  
  499.     $args{Comments}||= $COMMENTS_DEFAULT;
  500.     if( $args{Comments} eq 'drop')       { $self->{twig_keep_comments}= 0;    }
  501.     elsif( $args{Comments} eq 'keep')    { $self->{twig_keep_comments}= 1;    }
  502.     elsif( $args{Comments} eq 'process') { $self->{twig_process_comments}= 1; }
  503.     else { croak "wrong value for comments argument: '$args{Comments}' (should be 'drop', 'keep' or 'process')"; }
  504.     delete $args{Comments};
  505.  
  506.     $args{Pi}||= $PI_DEFAULT;
  507.     if( $args{Pi} eq 'drop')       { $self->{twig_keep_pi}= 0;    }
  508.     elsif( $args{Pi} eq 'keep')    { $self->{twig_keep_pi}= 1;    }
  509.     elsif( $args{Pi} eq 'process') { $self->{twig_process_pi}= 1; }
  510.     else { croak "wrong value for pi argument: '$args{Pi}' (should be 'drop', 'keep' or 'process')"; }
  511.     delete $args{Pi};
  512.  
  513.     if( $args{KeepEncoding})
  514.       { $self->{twig_keep_encoding}= $args{KeepEncoding};
  515.         # set it in XML::Twig::Elt so print functions know what to do
  516.         $self->set_keep_encoding( 1); 
  517.         $self->{parse_start_tag}= $args{ParseStartTag} || \&_parse_start_tag; 
  518.         delete $args{ParseStartTag} if defined( $args{ParseStartTag}) ;
  519.         delete $args{KeepEncoding};
  520.         $self->{NoExpand}= 1;
  521.       }
  522.     else
  523.       { $self->set_keep_encoding( 0);  
  524.         $self->{parse_start_tag}= $args{ParseStartTag} if( $args{ParseStartTag}); 
  525.       }
  526.  
  527.     if( $args{OutputFilter})
  528.       { $self->set_output_filter( $args{OutputFilter}); 
  529.         delete $args{OutputFilter};
  530.       }
  531.     else
  532.       { $self->set_output_filter( 0); }
  533.  
  534.     if( $args{RemoveCdata})
  535.       { $self->set_remove_cdata( $args{RemoveCdata}); 
  536.         delete $args{RemoveCdata}; 
  537.       }
  538.     else
  539.       { $self->set_remove_cdata( 0); }
  540.  
  541.     if( $args{OutputTextFilter})
  542.       { $self->set_output_text_filter( $args{OutputTextFilter}); 
  543.         delete $args{OutputTextFilter};
  544.       }
  545.     else
  546.       { $self->set_output_text_filter( 0); }
  547.  
  548.  
  549.     if( exists $args{KeepAttsOrder})
  550.       { $self->{keep_atts_order}= $args{KeepAttsOrder};
  551.         if( _use( 'Tie::IxHash'))
  552.           { $self->set_keep_atts_order(  $self->{keep_atts_order}); }
  553.         else 
  554.           { croak "Tie::IxHash not available, option keep_atts_order not allowed"; }
  555.       }
  556.     else
  557.       { $self->set_keep_atts_order( 0); }
  558.  
  559.     if( my $output_encoding= $args{OutputEncoding})
  560.       { $self->set_output_encoding( $output_encoding);
  561.         delete $args{OutputFilter};
  562.       }
  563.  
  564.     if( $args{InputFilter})
  565.       { $self->set_input_filter(  $args{InputFilter}); 
  566.         delete  $args{InputFilter}; 
  567.       }
  568.  
  569.     if( exists $args{Id}) { $ID= $args{Id}; delete $args{ID}; }
  570.  
  571.     if( $args{NoExpand})
  572.       { $self->setHandlers( %twig_noexpand_handlers);
  573.         $self->{twig_no_expand}=1;
  574.       }
  575.  
  576.     if( $args{NoProlog})
  577.       { $self->{no_prolog}= 1; 
  578.         delete $args{NoProlog}; 
  579.       }
  580.  
  581.     if( $args{DoNotOutputDTD})
  582.       { $self->{no_dtd_output}= 1; 
  583.         delete $args{DoNotOutputDTD}; 
  584.       }
  585.  
  586.     # set handlers
  587.     if( $self->{twig_roots})
  588.       { if( $self->{twig_default_print})
  589.           { if( $self->{twig_keep_encoding})
  590.               { $self->setHandlers( %twig_handlers_roots_print_original); }
  591.             else
  592.               { $self->setHandlers( %twig_handlers_roots_print);  }
  593.           }
  594.         else
  595.           { $self->setHandlers( %twig_handlers_roots); }
  596.       }
  597.     else
  598.       { $self->setHandlers( %twig_handlers); }
  599.  
  600.     # XML::Parser::Expat does not like these handler to be set. So in order to 
  601.     # use the various sets of handlers on XML::Parser or XML::Parser::Expat
  602.     # objects when needed, these ones have to be set only once, here, at 
  603.     # XML::Parser level
  604.     $self->setHandlers( Init => \&_twig_init, Final => \&_twig_final);
  605.  
  606.     $self->{twig_entity_list}= XML::Twig::Entity_list->new; 
  607.  
  608.     $self->{twig_id}= $ID; 
  609.     $self->{twig_stored_spaces}='';
  610.  
  611.     $self->{twig_autoflush}= 1; # auto flush by default
  612.  
  613.     $self->{twig}= $self;
  614.     weaken( $self->{twig}) if( $weakrefs);
  615.  
  616.     return $self;
  617.   }
  618.  
  619. # requires 5.006 at least (or the ${^UNICODE} causes a problem)
  620. sub parse                                                                                                 # > 5.006
  621.   { # trap underlying bug in IO::Handle (see RT #17500)                                                   # > 5.006
  622.     # croak if perl 5.8+, -CD (or PERL_UNICODE set to D) and parsing a pipe                               # > 5.006
  623.     if( $]>=5.008 && ${^UNICODE} && (${^UNICODE} & 24) && isa( $_[1], 'GLOB') && -p $_[1] )               # > 5.006
  624.       { croak   "cannot parse the output of a pipe when perl is set to use the UTF8 perlIO layer\n"       # > 5.006
  625.               . "set the environment variable PERL_UNICODE or use the -C option (see perldoc perlrun)\n"  # > 5.006
  626.               . "not to include 'D'";                                                                     # > 5.006
  627.       }                                                                                                   # > 5.006
  628.     shift->SUPER::parse( @_);                                                                             # > 5.006
  629.   }                                                                                                       # > 5.006
  630.  
  631. sub parsefile_inplace      { shift->_parse_inplace( parsefile      => @_); }
  632. sub parsefile_html_inplace { shift->_parse_inplace( parsefile_html => @_); }
  633.  
  634. sub _parse_inplace
  635.   { my( $t, $method, $file, $suffix)= @_;
  636.     _use( 'File::Temp') || die "need File::Temp to use inplace methods\n";
  637.     _use( 'File::Basename');
  638.  
  639.     my $tmpdir= dirname( $file);
  640.     my( $tmpfh, $tmpfile)= File::Temp::tempfile( DIR => $tmpdir);
  641.     my $original_fh= select $tmpfh;
  642.  
  643.     $t->$method( $file);
  644.  
  645.     select $original_fh;
  646.     close $tmpfh;
  647.  
  648.     if( $suffix) 
  649.       { my $backup;
  650.         if( $suffix=~ m{\*}) { ($backup = $suffix) =~ s/\*/$file/g; }
  651.         else                 { $backup= $file . $suffix; }
  652.           
  653.         rename( $file, $backup) or die "cannot backup initial file ($file) to $backup: $!"; 
  654.       }
  655.     rename( $tmpfile, $file) or die "cannot rename temp file ($tmpfile) to initial file ($file): $!";
  656.  
  657.     return $t;
  658.   }
  659.     
  660.  
  661. sub parseurl
  662.   { my $t= shift;
  663.     $t->_parseurl( 0, @_);
  664.   }
  665.  
  666. sub safe_parseurl
  667.   { my $t= shift;
  668.     $t->_parseurl( 1, @_);
  669.   }
  670.  
  671.  
  672. sub parsefile_html
  673.   { my $t= shift;
  674.     my $file= shift;
  675.     $t->parse( _html2xml( _slurp( $file)), @_);
  676.     return $t;
  677.   }
  678.  
  679. sub parse_html
  680.   { my $t= shift;
  681.     my $content= shift;
  682.     $t->parse( _html2xml( UNIVERSAL::isa( $content, 'GLOB') ? _slurp_fh( $content) : $content), @_);
  683.     return $t;
  684.   }
  685.  
  686. sub xparse
  687.   { my $t= shift;
  688.     my $to_parse= $_[0];
  689.     if( isa( $to_parse, 'GLOB'))             { $t->parse( @_);                 }
  690.     elsif( $to_parse=~ m{^\s*<})             { $to_parse=~ m{<html}i ? $t->_parse_as_xml_or_html( @_)
  691.                                                                      : $t->parse( @_);                 
  692.                                              }
  693.     elsif( $to_parse=~ m{^\w+://.*\.html?$}) { _use( 'LWP::Simple') or croak "missing LWP::Simple"; 
  694.                                                $t->_parse_as_xml_or_html( get( shift()), @_);
  695.                                              }
  696.     elsif( $to_parse=~ m{^\w+://})           { _use( 'LWP::Simple') or croak "missing LWP::Simple";
  697.                                                my $doc= get( shift);
  698.                                                my $xml_parse_ok= $t->safe_parse( $doc, @_);
  699.                                                if( $xml_parse_ok)
  700.                                                  { return $xml_parse_ok; }
  701.                                                else
  702.                                                  { my $diag= $@;
  703.                                                    if( $doc=~ m{<html}i)
  704.                                                      { $t->parse_html( $doc, @_); }
  705.                                                     else
  706.                                                       { die $diag; }
  707.                                                  }
  708.                                              }
  709.     elsif( $to_parse=~ m{\.html?$})          { my $content= _slurp( shift);
  710.                                                $t->_parse_as_xml_or_html( $content, @_); 
  711.                                              }
  712.     else                                     { $t->parsefile( @_);             }
  713.   }
  714.  
  715. sub _parse_as_xml_or_html
  716.   { my $t= shift; 
  717.     $t->safe_parse( @_) || $t->parse_html( @_); 
  718.   }  
  719.     
  720.  
  721. sub nparse
  722.   { my $class= shift;
  723.     my $to_parse= pop;
  724.     $class->new( @_)->xparse( $to_parse);
  725.   }
  726.  
  727. sub _html2xml
  728.   { my( $html)= @_;
  729.     _use( 'HTML::TreeBuilder', '3.13') or croak "cannot parse HTML: missing HTML::TreeBuilder v >= 3.13\n"; 
  730.     my $tree= HTML::TreeBuilder->new->parse( $html);
  731.     my $xml= $tree->as_XML;
  732.     $tree->delete;
  733.     return $xml;
  734.   }
  735.  
  736. sub add_stylesheet
  737.   { my( $t, $type, $href)= @_;
  738.     my %text_type= map { $_ => 1 } qw( xsl css);
  739.     my $ss= $t->{twig_elt_class}->new( '#PI');
  740.     if( $text_type{$type}) 
  741.       { $ss->_set_pi( 'xml-stylesheet', qq{type="text/$type" href="$href"}); }
  742.     else
  743.       { croak "unsupported style sheet type '$type'"; }
  744.       
  745.     $t->_add_cpi_outside_of_root( leading_cpi => $ss);
  746.     return $t;
  747.   }
  748.  
  749. { my %used;       # module => 1 if require ok, 0 otherwise
  750.   my %disallowed; # for testing, refuses to _use modules in this hash
  751.  
  752.   sub _disallow_use
  753.     { my( @modules)= @_;
  754.       $disallowed{$_}= 1 foreach (@modules);
  755.     }
  756.  
  757.   sub _allow_use
  758.     { my( @modules)= @_;
  759.       $disallowed{$_}= 0 foreach (@modules);
  760.     }
  761.  
  762.   sub _use
  763.     { my( $module, $version)= @_;
  764.       $version ||= 0;
  765.       if( $disallowed{$module})   { return 0; }
  766.       if( $used{$module})         { return 1; }
  767.       if( eval "require $module") { import $module; $used{$module}= 1; 
  768.                                     no strict 'refs';
  769.                                     if( ${"${module}::VERSION"} >= $version ) { return 1; }
  770.                                     else                                      { return 0;  }
  771.                                   }
  772.       else                        {                 $used{$module}= 0; return 0; }
  773.     }
  774. }
  775.  
  776. # used to solve the [n] predicates while avoiding getting the entire list
  777. sub _first_n(&$@)        # needs a prototype to accept passing bare blocks
  778.   { my $coderef= shift;
  779.     my $n= shift;         
  780.     my $i=0;
  781.     if( $n > 0)
  782.       { foreach (@_)         { if( &$coderef) { $i++; return $_ if( $i == $n); } } }
  783.     elsif( $n < 0)
  784.       { foreach (reverse @_) { if( &$coderef) { $i--; return $_ if( $i == $n); } } }
  785.     else
  786.       { croak "illegal position number 0"; }
  787.   }
  788.  
  789. sub _slurp_uri
  790.   { my( $uri)= @_;
  791.     if( $uri=~ m{^\w+://})
  792.       { _use( 'LWP::Simple'); return get( $uri); }
  793.     else
  794.       { return _slurp( $uri); }
  795.   }
  796.  
  797. sub _slurp
  798.   { my( $filename)= @_;
  799.     # use bareword filehandle to stay compatible with real old perl
  800.     open( TWIG_TO_SLURP, "<$filename") or croak "cannot open '$filename': $!"; 
  801.     local $/= undef;
  802.     my $content= <TWIG_TO_SLURP>;
  803.     close TWIG_TO_SLURP;
  804.     return $content;
  805.   }
  806.   
  807. sub _slurp_fh
  808.   { my( $fh)= @_;
  809.     local $/= undef;
  810.     my $content= <$fh>;
  811.     return $content;
  812.   }    
  813.  
  814. # I should really add extra options to allow better configuration of the 
  815. # LWP::UserAgent object
  816. # this method forks (except on VMS!)
  817. #   - the child gets the data and copies it to the pipe,
  818. #   - the parent reads the stream and sends it to XML::Parser
  819. # the data is cut it chunks the size of the XML::Parser::Expat buffer
  820. # the method returns the twig and the status
  821. sub _parseurl
  822.   { my( $t, $safe, $url, $agent)= @_;
  823.     _use( 'LWP') || croak "LWP not available, needed to use parseurl methods";
  824.     if( $^O ne 'VMS')
  825.       { pipe( README, WRITEME) or croak  "cannot create connected pipes: $!";
  826.         if( my $pid= fork)
  827.           { # parent code: parse the incoming file
  828.             close WRITEME; # no need to write
  829.             my $result= $safe ? $t->safe_parse( \*README) : $t->parse( \*README);
  830.             close README;
  831.             return $@ ? 0 : $t;
  832.           }
  833.         else
  834.          { # child
  835.             close README; # no need to read
  836.             $|=1;
  837.             $agent    ||= LWP::UserAgent->new;
  838.             my $request  = HTTP::Request->new( GET => $url);
  839.             # _pass_url_content is called with chunks of data the same size as
  840.             # the XML::Parser buffer 
  841.             my $response = $agent->request( $request, 
  842.                              sub { _pass_url_content( \*WRITEME, @_); }, BUFSIZE);
  843.             $response->is_success or croak "$url ", $response->message;
  844.             close WRITEME;
  845.             CORE::exit(); # CORE is there for mod_perl (which redefines exit)
  846.           }
  847.       } 
  848.     else 
  849.       { $|=1;
  850.         $agent    ||= LWP::UserAgent->new;
  851.         my $request  = HTTP::Request->new( GET => $url);
  852.         my $response = $agent->request( $request);
  853.         $response->is_success or croak "$url ", $response->message;
  854.         my $result= $safe ? $t->safe_parse($response->content) : $t->parse($response->content);
  855.         return $@ ? 0 : $t;
  856.      }
  857.  
  858.   }
  859.  
  860. # get the (hopefully!) XML data from the URL and 
  861. sub _pass_url_content
  862.   { my( $fh, $data, $response, $protocol)= @_;
  863.     print {$fh} $data;
  864.   }
  865.  
  866. sub add_options
  867.   { my %args= map { $_, 1 } @_;
  868.     %args= _normalize_args( %args);
  869.     foreach (keys %args) { $valid_option{$_}++; } 
  870.   }
  871.  
  872. sub _twig_store_internal_dtd
  873.   { 
  874.     my( $p, $string)= @_;
  875.     my $t= $p->{twig};
  876.     $string= $p->original_string() if( $t->{twig_keep_encoding});
  877.     $t->{twig_doctype}->{internal} .= $string;
  878.   }
  879.  
  880. sub _twig_stop_storing_internal_dtd
  881.   { my $p= shift;
  882.     if( @saved_default_handler && defined $saved_default_handler[1])
  883.       { $p->setHandlers( @saved_default_handler); }
  884.     else
  885.       { my $t= $p->{twig};
  886.         $p->setHandlers( Default => undef);
  887.       }
  888.     $p->{twig}->{twig_doctype}->{internal}=~ s{^\s*\[}{};
  889.     $p->{twig}->{twig_doctype}->{internal}=~ s{\]\s*$}{};
  890.   }
  891.  
  892.  
  893. sub _normalize_args
  894.   { my %normalized_args;
  895.     while( my $key= shift )
  896.       { $key= join '', map { ucfirst } split /_/, $key;
  897.         #$key= "Twig".$key unless( substr( $key, 0, 4) eq 'Twig');
  898.         $normalized_args{$key}= shift ;
  899.       }
  900.     return %normalized_args;
  901.   }    
  902.  
  903. sub _is_fh { return unless $_[0]; return $_[0] if( isa( $_[0], 'GLOB') || isa( $_[0], 'IO::Scalar')); }
  904.  
  905. sub _set_handler
  906.   { my( $handlers, $path, $handler)= @_;
  907.  
  908.     my $prev_handler= $handlers->{handlers}->{string}->{$path} || undef;
  909.  
  910.        _set_gi_handler              ( $handlers, $path, $handler, $prev_handler)
  911.     || _set_path_handler            ( $handlers, $path, $handler, $prev_handler)
  912.     || _set_subpath_handler         ( $handlers, $path, $handler, $prev_handler)
  913.     || _set_attribute_handler       ( $handlers, $path, $handler, $prev_handler)
  914.     || _set_star_att_handler        ( $handlers, $path, $handler, $prev_handler)
  915.     || _set_star_att_regexp_handler ( $handlers, $path, $handler, $prev_handler)
  916.     || _set_string_handler          ( $handlers, $path, $handler, $prev_handler)
  917.     || _set_attribute_regexp_handler( $handlers, $path, $handler, $prev_handler)
  918.     || _set_string_regexp_handler   ( $handlers, $path, $handler, $prev_handler)
  919.     || _set_pi_handler              ( $handlers, $path, $handler, $prev_handler)
  920.     || _set_level_handler           ( $handlers, $path, $handler, $prev_handler)
  921.     || _set_regexp_handler          ( $handlers, $path, $handler, $prev_handler)
  922.     || croak "unrecognized expression in handler: '$path'";
  923.  
  924.  
  925.     # this both takes care of the simple (gi) handlers and store
  926.     # the handler code reference for other handlers
  927.     $handlers->{handlers}->{string}->{$path}= $handler;
  928.  
  929.     return $prev_handler;
  930.   }
  931.  
  932.  
  933. sub _set_gi_handler
  934.   { my( $handlers, $path, $handler, $prev_handler)= @_;
  935.     if( $path =~ m{^\s*($REG_NAME)\s*$}o )
  936.       { my $gi= $1;
  937.         $handlers->{handlers}->{gi}->{$gi}= $handler; 
  938.         return 1;
  939.       }
  940.     else 
  941.       { return 0; }
  942.   }
  943.  
  944. sub _set_path_handler
  945.   { my( $handlers, $path, $handler, $prev_handler)= @_;
  946.     if( $path=~ m{^\s*(?:/$REG_NAME)*/($REG_NAME)\s*$}o)
  947.       { # a full path has been defined
  948.         # update the path_handlers count, knowing that
  949.         # either the previous or the new handler can be undef
  950.         $handlers->{path_handlers}->{gi}->{$1}-- if( $prev_handler);
  951.         if( $handler)
  952.          { $handlers->{path_handlers}->{gi}->{$1}++;
  953.            $handlers->{path_handlers}->{string}->{$path}= $handler;
  954.          }
  955.         return 1;
  956.       }
  957.     else 
  958.       { return 0; }
  959.   }
  960.  
  961. sub _set_subpath_handler
  962.   { my( $handlers, $path, $handler, $prev_handler)= @_;
  963.     if( $path=~ m{^\s*(?:$REG_NAME/)+($REG_NAME)\s*$}o)
  964.       { # a partial path has been defined
  965.         # $1 is the "final" gi
  966.         $handlers->{subpath_handlers}->{gi}->{$1}-- if( $prev_handler);
  967.         if( $handler)
  968.          { $handlers->{subpath_handlers}->{gi}->{$1}++;
  969.            $handlers->{subpath_handlers}->{string}->{$path}= $handler;
  970.          }
  971.         return 1;
  972.       }
  973.     else 
  974.       { return 0; }
  975.   }
  976.  
  977.  
  978. sub _set_attribute_handler
  979.   { my( $handlers, $path, $handler, $prev_handler)= @_;
  980.     # check for attribute conditions
  981.     if( $path=~ m{^\s*($REG_NAME)          # elt
  982.                  \s*\[\s*\@                #    [@
  983.                  ($REG_NAME)\s*            #      att
  984.                  (?:=\s*($REG_STRING)\s*)? #           = value (optional)         
  985.                  \]\s*$}xo)                #                             ]  
  986.       { my( $gi, $att, $val)= ($1, $2, $3);
  987.         $val= substr( $val, 1, -1) if( defined $val); # remove the quotes
  988.         if( $prev_handler)
  989.           { # replace or remove the previous handler
  990.             my $i=0; # so we can splice the array if need be
  991.             foreach my $exp ( @{$handlers->{attcond_handlers_exp}->{$gi}})
  992.              { if( ($exp->{att} eq $att) && ( _eq( $exp->{val}, $val)) )
  993.                  { if( $handler) # just replace the handler
  994.                      { $exp->{handler}= $handler; }
  995.                    else          # remove the handler
  996.                      { $handlers->{attcond_handlers}->{$gi}--;
  997.                        splice( @{$handlers->{attcond_handlers_exp}->{$gi}}, $i, 1);
  998.                        last;
  999.                      }
  1000.                  }
  1001.                $i++;
  1002.              }
  1003.           }
  1004.         elsif( $handler)
  1005.           { # new handler only
  1006.             $handlers->{attcond_handlers}->{$gi}++;
  1007.             my $exp={att => $att, val => $val, handler => $handler};
  1008.             $handlers->{attcond_handlers_exp}->{$gi} ||= [];
  1009.             push @{$handlers->{attcond_handlers_exp}->{$gi}}, $exp;
  1010.           }
  1011.         return 1;
  1012.       }
  1013.     else 
  1014.       { return 0; }
  1015.   }
  1016.  
  1017.  
  1018. sub _set_attribute_regexp_handler
  1019.   { my( $handlers, $path, $handler, $prev_handler)= @_;
  1020.     # check for attribute regexp conditions
  1021.     if( $path=~ m{^\s*($REG_NAME)     # elt
  1022.                  \s*\[\s*\@           #    [@
  1023.                  ($REG_NAME)          #      att
  1024.                  \s*=~\s*             #          =~
  1025.                  /($REG_REGEXP_EXP)/  #             /regexp/
  1026.                  ($REG_REGEXP_MOD)    #                     mods
  1027.                  \s*]\s*$}gxo)        #                         ] 
  1028.       { my( $gi, $att, $regexp, $mods)= ($1, $2, $3, $4);
  1029.         $regexp= qr/(?$mods:$regexp)/;
  1030.         if( $prev_handler)
  1031.           { # replace or remove the previous handler
  1032.             my $i=0; # so we can splice the array if need be
  1033.             foreach my $exp ( @{$handlers->{attregexp_handlers_exp}->{$gi}})
  1034.              { if( ($exp->{att} eq $att) && ($exp->{regexp} eq $regexp) )
  1035.                  { if( $handler) # just replace the handler
  1036.                      { $exp->{handler}= $handler; }
  1037.                    else          # remove the handler
  1038.                      { $handlers->{attregexp_handlers}->{$gi}--;
  1039.                        splice( @{$handlers->{attregexp_handlers_exp}->{$gi}}, $i, 1);
  1040.                        last;
  1041.                      }
  1042.                  }
  1043.                $i++;
  1044.              }
  1045.           }
  1046.         elsif( $handler)
  1047.           { # new handler only
  1048.             $handlers->{attregexp_handlers}->{$gi}++;
  1049.             my $exp={att => $att, regexp => $regexp, handler => $handler};
  1050.             $handlers->{attregexp_handlers_exp}->{$gi} ||= [];
  1051.             push @{$handlers->{attregexp_handlers_exp}->{$gi}}, $exp;
  1052.           }
  1053.         return 1;
  1054.       }
  1055.     else 
  1056.       { return 0; }
  1057.   }
  1058.  
  1059. sub _set_string_handler
  1060.   { my( $handlers, $path, $handler, $prev_handler)= @_;
  1061.     # check for string conditions
  1062.     if( $path=~/^\s*($REG_NAME)            # elt
  1063.                  \s*\[\s*string            #    [string
  1064.                  \s*\(\s*($REG_NAME)?\s*\) #           (sub_elt)
  1065.                  \s*=\s*                   #                     =
  1066.                  ($REG_STRING)             #                       "text" (or 'text')
  1067.                  \s*\]\s*$/ox)             #                              ] 
  1068.       { my( $gi, $sub_elt, $text)= ($1, $2, $3);
  1069.         $text= substr( $text, 1, -1) if( defined $text); # remove the quotes
  1070.         if( $prev_handler)
  1071.           { # replace or remove the previous handler
  1072.             my $i=0; # so we can splice the array if need be
  1073.             foreach my $exp ( @{$handlers->{text_handlers_exp}->{$gi}})
  1074.              { if( ($exp->{text} eq $text) &&
  1075.                    ( !$exp->{sub_elt} || ($exp->{sub_elt} eq $sub_elt) )
  1076.                  )
  1077.                  { if( $handler) # just replace the handler
  1078.                      { $exp->{handler}= $handler; }
  1079.                    else          # remove the handler
  1080.                      { $handlers->{text_handlers}->{$gi}--;
  1081.                        splice( @{$handlers->{text_handlers_exp}->{$gi}}, $i, 1);
  1082.                        last;
  1083.                      }
  1084.                  }
  1085.                $i++;
  1086.              }
  1087.           }
  1088.         elsif( $handler)
  1089.           { # new handler only
  1090.             $handlers->{text_handlers}->{$gi}++;
  1091.             my $exp={sub_elt => $sub_elt, text => $text, handler => $handler};
  1092.             $handlers->{text_handlers_exp}->{$gi} ||= [];
  1093.             push @{$handlers->{text_handlers_exp}->{$gi}}, $exp;
  1094.           }
  1095.         return 1;
  1096.       }
  1097.     else 
  1098.       { return 0; 
  1099.       }
  1100.   }
  1101.  
  1102.  
  1103. sub _set_string_regexp_handler
  1104.   { my( $handlers, $path, $handler, $prev_handler)= @_;
  1105.     # check for string regexp conditions
  1106.     if( $path=~m{^\s*($REG_NAME)        # (elt)
  1107.                  \s*\[\s*string         #    [string
  1108.                  \s*\(\s*($REG_NAME?)\) #           (sub_elt)
  1109.                  \s*=~\s*               #              =~ 
  1110.                  /($REG_REGEXP_EXP)/    #                 /(regexp)/
  1111.                  \s*($REG_REGEXP_MOD)?  #                         (mods)
  1112.                  \s*\]\s*$}ox)          #                             ]   (or ')
  1113.       { my( $gi, $sub_elt, $regexp, $mods)= ($1, $2, $3, $4);
  1114.         $mods||="";
  1115.         $regexp= qr/(?$mods:$regexp)/;
  1116.         if( $prev_handler)
  1117.           { # replace or remove the previous handler
  1118.             my $i=0; # so we can splice the array if need be
  1119.             foreach my $exp ( @{$handlers->{regexp_handlers_exp}->{$gi}})
  1120.              { if( ($exp->{regexp} eq $regexp) &&
  1121.                    ( !$exp->{sub_elt} || ($exp->{sub_elt} eq $sub_elt) )
  1122.                  )
  1123.                  { if( $handler) # just replace the handler
  1124.                      { $exp->{handler}= $handler;  
  1125.                      }
  1126.                    else          # remove the handler
  1127.                      { $handlers->{regexp_handlers}->{$gi}--;
  1128.                        splice( @{$handlers->{regexp_handlers_exp}->{$gi}}, $i, 1);
  1129.                        last;
  1130.                      }
  1131.                  }
  1132.                $i++;
  1133.              }
  1134.           }
  1135.         elsif( $handler)
  1136.           { # new handler only
  1137.             $handlers->{regexp_handlers}->{$gi}++;
  1138.             my $exp= {sub_elt => $sub_elt, regexp => $regexp, handler => $handler};
  1139.             $handlers->{regexp_handlers_exp}->{$gi} ||= [];
  1140.             push @{$handlers->{regexp_handlers_exp}->{$gi}}, $exp;
  1141.           }
  1142.         return 1;
  1143.       }
  1144.     else 
  1145.       { return 0; 
  1146.       }
  1147.   }
  1148.  
  1149.  
  1150. sub _set_star_att_handler
  1151.   { my( $handlers, $path, $handler, $prev_handler)= @_;
  1152.     # check for *[@att="val"] or *[@att] conditions
  1153.     if( $path=~/^(?:\s*\*)?         # * (optional)
  1154.                  \s*\[\s*\@         #    [@
  1155.                  ($REG_NAME)        #      att
  1156.                  (?:\s*=\s*         #         = 
  1157.                  ($REG_STRING))?    #           string
  1158.                      \s*\]\s*$/ox)  #                 ]  
  1159.       { my( $att, $val)= ($1, $2);
  1160.         $val= substr( $val, 1, -1) if( defined $val); # remove the quotes from the string
  1161.         if( $prev_handler)
  1162.           { # replace or remove the previous handler
  1163.             my $i=0; # so we can splice the array if need be
  1164.             foreach my $exp ( @{$handlers->{att_handlers_exp}->{$att}})
  1165.              { if( ($exp->{att} eq $att) && ( !defined( $val) || _eq( $exp->{val}, $val) ) )
  1166.                  { if( $handler) # just replace the handler
  1167.                      { $exp->{handler}= $handler; }
  1168.                    else          # remove the handler
  1169.                      { splice( @{$handlers->{att_handlers_exp}->{$att}}, $i, 1);
  1170.                        $handlers->{att_handlers}->{$att}--;
  1171.                        last;
  1172.                      }
  1173.                  }
  1174.                $i++;
  1175.              }
  1176.           }
  1177.         elsif( $handler)
  1178.           { # new handler only
  1179.             $handlers->{att_handlers}->{$att}++;
  1180.             my $exp={att => $att, val => $val, handler => $handler};
  1181.             $handlers->{att_handlers_exp}->{$att} ||= [];
  1182.             push @{$handlers->{att_handlers_exp}->{$att}}, $exp;
  1183.           }
  1184.         return 1;
  1185.       }
  1186.     else 
  1187.       { return 0; 
  1188.       }
  1189.   }
  1190.  
  1191. sub _set_star_att_regexp_handler
  1192.   { my( $handlers, $path, $handler, $prev_handler)= @_;
  1193.     # check for *[@att=~ /regexp/] conditions
  1194.     if( $path=~ m{^(?:\s*\*)?             # * (optional)
  1195.                    \s*\[\s*\@             #  [@
  1196.                    ($REG_NAME)            #    att
  1197.                    \s*=~\s*               #        =~ 
  1198.                    /($REG_REGEXP_EXP)/    #           /(regexp)/
  1199.                    \s*($REG_REGEXP_MOD)?  #                     (mods)
  1200.                    \s*\]\s*$}ox)          #                           ]  
  1201.       { my( $att, $regexp, $mods)= ($1, $2, $3);
  1202.         $mods||="";
  1203.         $regexp= qr/(?$mods:$regexp)/;
  1204.         if( $prev_handler)
  1205.           { # replace or remove the previous handler
  1206.             my $i=0; # so we can splice the array if need be
  1207.             foreach my $exp ( @{$handlers->{att_regexp_handlers_exp}->{$att}})
  1208.              { if( $exp->{regexp} eq $regexp)
  1209.                  { if( $handler) # just replace the handler
  1210.                      { $exp->{handler}= $handler;  
  1211.                      }
  1212.                    else          # remove the handler
  1213.                      { splice( @{$handlers->{att_regexp_handlers_exp}->{$att}}, $i, 1);
  1214.                    $handlers->{att_regexp_handlers}--;
  1215.                        last;
  1216.                      }
  1217.                  }
  1218.                $i++;
  1219.              }
  1220.           }
  1221.         elsif( $handler)
  1222.           { # new handler only
  1223.             my $exp= { regexp => $regexp, handler => $handler};
  1224.             $handlers->{regexp_handlers_exp}->{$att} ||= [];
  1225.             push @{$handlers->{att_regexp_handlers_exp}->{$att}}, $exp;
  1226.             $handlers->{att_regexp_handlers}++;
  1227.           }
  1228.         return 1;
  1229.       }
  1230.     else 
  1231.       { return 0; 
  1232.       }
  1233.   }
  1234.  
  1235.  
  1236. sub _set_pi_handler
  1237.   { my( $handlers, $path, $handler, $prev_handler)= @_;
  1238.     # PI conditions ( '?target' => \&handler or '?' => \&handler
  1239.     #             or '#PItarget' => \&handler or '#PI' => \&handler)
  1240.     if( $path=~ /^\s*(?:\?|#PI)\s*(?:([^\s]*)\s*)$/)
  1241.       { my $target= $1 || '';
  1242.         # update the path_handlers count, knowing that
  1243.         # either the previous or the new handler can be undef
  1244.         $handlers->{pi_handlers}->{$1}= $handler;
  1245.         return 1;
  1246.       }
  1247.     else 
  1248.       { return 0; 
  1249.       }
  1250.   }
  1251.  
  1252. sub _set_level_handler
  1253.   { my( $handlers, $path, $handler, $prev_handler)= @_;
  1254.     if( $path =~ m{^ \s* level \s* \( \s* ([0-9]+) \s* \) \s* $}ox )
  1255.       { my $level= $1;
  1256.         $handlers->{handlers}->{level}->{$level}= $handler; 
  1257.         return 1;
  1258.       }
  1259.     else 
  1260.       { return 0; }
  1261.   }
  1262.  
  1263. sub _set_regexp_handler
  1264.   { my( $handlers, $path, $handler, $prev_handler)= @_; 
  1265.     # if the expression was a regexp it is now a string (it was stringified when it became a hash key)
  1266.     if( $path=~ m{^\(\?([xism]*)(?:-[xism]*)?:(.*)\)$}) 
  1267.       { my $regexp= qr/(?$1:$2)/; # convert it back into a regexp
  1268.         $handlers->{handlers}->{regexp}->{$path}= { regexp => $regexp, handler => $handler}; 
  1269.         return 1;
  1270.       }
  1271.     else 
  1272.       { return 0; }
  1273.   }
  1274.  
  1275.  
  1276. # just like eq except that undef values do not trigger warnings
  1277. sub _eq
  1278.   { my( $val1, $val2)= @_;
  1279.     if( !defined $val1) { return !defined $val2 }
  1280.     if( !defined $val2) { return 0; }
  1281.     return $val1 eq $val2;
  1282.   }
  1283.  
  1284. sub setCharHandler
  1285.   { my( $t, $handler)= @_;
  1286.     $t->{twig_char_handler}= $handler;
  1287.   }
  1288.  
  1289.  
  1290. sub _reset_handlers
  1291.   { my $handlers= shift;
  1292.     delete $handlers->{handlers};
  1293.     delete $handlers->{path_handlers};
  1294.     delete $handlers->{subpath_handlers};
  1295.     $handlers->{attcond_handlers_exp}=[] if( $handlers->{attcond_handlers});
  1296.     delete $handlers->{attcond_handlers};
  1297.   }
  1298.   
  1299. sub _set_handlers
  1300.   { my $handlers= shift || return;
  1301.     my $set_handlers= {};
  1302.     foreach my $path (keys %{$handlers})
  1303.       { _set_handler( $set_handlers, $path, $handlers->{$path}); }
  1304.     return $set_handlers;
  1305.   }
  1306.     
  1307.  
  1308. sub setTwigHandler
  1309.   { my( $t, $path, $handler)= @_;
  1310.     $t->{twig_handlers} ||={};
  1311.     return _set_handler( $t->{twig_handlers}, $path, $handler);
  1312.   }
  1313.  
  1314. sub setTwigHandlers
  1315.   { my( $t, $handlers)= @_;
  1316.     my $previous_handlers= $t->{twig_handlers} || undef;
  1317.     _reset_handlers( $t->{twig_handlers});
  1318.     $t->{twig_handlers}= _set_handlers( $handlers);
  1319.     return $previous_handlers;
  1320.   }
  1321.  
  1322. sub setStartTagHandler
  1323.   { my( $t, $path, $handler)= @_;
  1324.     $t->{twig_starttag_handlers}||={};
  1325.     return _set_handler( $t->{twig_starttag_handlers}, $path, $handler);
  1326.   }
  1327.  
  1328. sub setStartTagHandlers
  1329.   { my( $t, $handlers)= @_;
  1330.     my $previous_handlers= $t->{twig_starttag_handlers} || undef;
  1331.     _reset_handlers( $t->{twig_starttag_handlers});
  1332.     $t->{twig_starttag_handlers}= _set_handlers( $handlers);
  1333.     return $previous_handlers;
  1334.    }
  1335.  
  1336. sub setIgnoreEltsHandler
  1337.   { my( $t, $path, $action)= @_;
  1338.     $t->{twig_ignore_elts_handlers}||={};
  1339.     return _set_handler( $t->{twig_ignore_elts_handlers}, $path, $action );
  1340.   }
  1341.  
  1342. sub setIgnoreEltsHandlers
  1343.   { my( $t, $handlers)= @_;
  1344.     my $previous_handlers= $t->{twig_ignore_elts_handlers};
  1345.     _reset_handlers( $t->{twig_ignore_elts_handlers});
  1346.     $t->{twig_ignore_elts_handlers}= _set_handlers( $handlers);
  1347.     return $previous_handlers;
  1348.    }
  1349.  
  1350. sub setEndTagHandler
  1351.   { my( $t, $path, $handler)= @_;
  1352.     $t->{twig_endtag_handlers}||={};
  1353.     return _set_handler( $t->{twig_endtag_handlers}, $path,$handler);
  1354.   }
  1355.  
  1356. sub setEndTagHandlers
  1357.   { my( $t, $handlers)= @_;
  1358.     my $previous_handlers= $t->{twig_endtag_handlers};
  1359.     _reset_handlers( $t->{twig_endtag_handlers});
  1360.     $t->{twig_endtag_handlers}= _set_handlers( $handlers);
  1361.     return $previous_handlers;
  1362.    }
  1363.  
  1364. # a little more complex: set the twig_handlers only if a code ref is given
  1365. sub setTwigRoots
  1366.   { my( $t, $handlers)= @_;
  1367.     my $previous_roots= $t->{twig_roots};
  1368.     _reset_handlers($t->{twig_roots});
  1369.     $t->{twig_roots}= _set_handlers( $handlers);
  1370.  
  1371.     _check_illegal_twig_roots_handlers( $t->{twig_roots});
  1372.     
  1373.     foreach my $path (keys %{$handlers})
  1374.       { $t->{twig_handlers}||= {};
  1375.         _set_handler( $t->{twig_handlers}, $path, $handlers->{$path})
  1376.           if( isa( $handlers->{$path}, 'CODE')); 
  1377.       }
  1378.     return $previous_roots;
  1379.   }
  1380.  
  1381. { my %type2message;
  1382.   BEGIN { %type2message= ( text_handlers   => "string() condition not supported on twig_roots option",
  1383.                            regexp_handlers => "regexp condition not supported on twig_roots option",
  1384.                          );
  1385.         }
  1386.         
  1387.   sub _check_illegal_twig_roots_handlers
  1388.     { my( $handlers)= @_;
  1389.       foreach my $type (keys %type2message)
  1390.         { if( exists $handlers->{$type})
  1391.             { die $type2message{$type}; }
  1392.         }
  1393.     }
  1394. }
  1395.     
  1396.  
  1397. # just store the reference to the expat object in the twig
  1398. sub _twig_init
  1399.   { 
  1400.     my $p= shift;
  1401.     my $t=$p->{twig};
  1402.  
  1403.     if( $t->{twig_parsing} ) { croak "cannot reuse a twig that is already parsing"; }
  1404.     $t->{twig_parsing}=1;
  1405.  
  1406.     $t->{twig_parser}= $p; 
  1407.     weaken( $t->{twig_parser}) if( $weakrefs);
  1408.  
  1409.     # in case they had been created by a previous parse
  1410.     delete $t->{twig_dtd};
  1411.     delete $t->{twig_doctype};
  1412.     delete $t->{twig_xmldecl};
  1413.  
  1414.     # if needed set the output filehandle
  1415.     $t->_set_fh_to_twig_output_fh();
  1416.   }
  1417.  
  1418. # uses eval to catch the parser's death
  1419. sub safe_parse
  1420.   { my $t= shift;
  1421.     eval { $t->parse( @_); } ;
  1422.     return $@ ? $t->_reset_twig &&  0 : $t;
  1423.   }
  1424.  
  1425. sub safe_parsefile
  1426.   { my $t= shift;
  1427.     eval { $t->parsefile( @_); } ;
  1428.     return $@ ? $t->_reset_twig : $t;
  1429.   }
  1430.  
  1431. # restore a twig in a proper state so it can be reused for a new parse
  1432. sub _reset_twig
  1433.   { my $t= shift;
  1434.     $t->{twig_parsing}= 0;
  1435.     delete $t->{twig_current};
  1436.     delete $t->{extra_data};
  1437.     delete $t->{twig_dtd};
  1438.     delete $t->{twig_in_pcdata};
  1439.     delete $t->{twig_in_cdata};
  1440.     delete $t->{twig_stored_space};
  1441.     delete $t->{twig_entity_list};
  1442.     $t->root->delete if( $t->root);
  1443.     delete $t->{root};
  1444.   }
  1445.  
  1446.  
  1447. sub _add_or_discard_stored_spaces
  1448.   { my $t= shift;
  1449.     my %option= @_;
  1450.    
  1451.     return unless( $t->{twig_current}); # ugly hack, with ignore twig_current can disappear 
  1452.     if( $t->{twig_stored_spaces} || $option{force} || $t->{twig_preserve_space})
  1453.       { if( $t->{twig_current}->is_pcdata)
  1454.           { $t->{twig_current}->append_pcdata($t->{twig_stored_spaces}); }
  1455.         else
  1456.           { my $current_gi= $t->{twig_current}->gi;
  1457.             unless( defined( $t->{twig_space_policy}->{$current_gi}))
  1458.               { $t->{twig_space_policy}->{$current_gi}= _space_policy( $t, $current_gi); }
  1459.  
  1460.             if(    $t->{twig_space_policy}->{$current_gi} ||  ($t->{twig_stored_spaces}!~ m{\n})
  1461.                 || $option{force} || $t->{twig_preserve_space}
  1462.               )
  1463.               { _insert_pcdata( $t, $t->{twig_stored_spaces} ); }
  1464.             $t->{twig_stored_spaces}='';
  1465.  
  1466.           }
  1467.       }
  1468.   }
  1469.  
  1470. # the default twig handlers, which build the tree
  1471. sub _twig_start
  1472.   { 
  1473.     my ($p, $gi, @att)= @_;
  1474.     my $t=$p->{twig};
  1475.  
  1476.     # empty the stored pcdata (space stored in case they are really part of 
  1477.     # a pcdata element) or stored it if the space policy dictades so
  1478.     # create a pcdata element with the spaces if need be
  1479.     _add_or_discard_stored_spaces( $t);
  1480.     my $parent= $t->{twig_current};
  1481.  
  1482.     # if we were parsing PCDATA then we exit the pcdata
  1483.     if( $t->{twig_in_pcdata})
  1484.       { $t->{twig_in_pcdata}= 0;
  1485.         delete $parent->{'twig_current'};
  1486.         $parent= $parent->{parent};
  1487.       }
  1488.  
  1489.     # if we choose to keep the encoding then we need to parse the tag
  1490.     if( my $func = $t->{parse_start_tag})
  1491.       { ($gi, @att)= &$func($p->original_string); }
  1492.     elsif( $t->{twig_entities_in_attribute})
  1493.       { 
  1494.        ($gi,@att)= _parse_start_tag( $p->recognized_string); 
  1495.          $t->{twig_entities_in_attribute}=0;
  1496.       }
  1497.  
  1498.     # if we are using an external DTD, we need to fill the default attributes
  1499.     if( $t->{twig_read_external_dtd}) { _fill_default_atts( $t, $gi, \@att); }
  1500.     
  1501.     # filter the input data if need be  
  1502.     if( my $filter= $t->{twig_input_filter})
  1503.       { $gi= $filter->( $gi);
  1504.         @att= map { $filter->($_) } @att; 
  1505.       }
  1506.  
  1507.     _replace_ns( $t, \$gi, \@att) if( $t->{twig_map_xmlns});
  1508.  
  1509.     my $elt= $t->{twig_elt_class}->new( $gi);
  1510.     $elt->set_atts( @att);
  1511.  
  1512.     delete $parent->{'twig_current'} if( $parent);
  1513.     $t->{twig_current}= $elt;
  1514.     $elt->{'twig_current'}=1;
  1515.  
  1516.     if( $parent)
  1517.       { my $prev_sibling= $parent->{last_child};
  1518.         if( $prev_sibling) 
  1519.           { $prev_sibling->{next_sibling}=  $elt; 
  1520.             $elt->set_prev_sibling( $prev_sibling);
  1521.           }
  1522.  
  1523.         $elt->set_parent( $parent);
  1524.         $parent->{first_child}=  $elt unless( $parent->{first_child}); 
  1525.         $parent->set_last_child( $elt);
  1526.       }
  1527.     else 
  1528.       { # processing root
  1529.         $t->set_root( $elt);
  1530.         # call dtd handler if need be
  1531.         $t->{twig_dtd_handler}->($t, $t->{twig_dtd})
  1532.           if( defined $t->{twig_dtd_handler});
  1533.       
  1534.         # set this so we can catch external entities
  1535.         # (the handler was modified during DTD processing)
  1536.         if( $t->{twig_default_print})
  1537.           { $p->setHandlers( Default => \&_twig_print); }
  1538.         elsif( $t->{twig_roots})
  1539.           { $p->setHandlers( Default => sub { return }); }
  1540.         else
  1541.           { $p->setHandlers( Default => \&_twig_default); }
  1542.       }
  1543.    
  1544.     $elt->{empty}=  $p->recognized_string=~ m{/\s*>$}s ? 1 : 0;
  1545.  
  1546.     $elt->{extra_data}= $t->{extra_data} if( $t->{extra_data});
  1547.     $t->{extra_data}='';
  1548.  
  1549.     # if the element is ID-ed then store that info
  1550.     my $id= $elt->{'att'}->{$ID};
  1551.     if( defined $id)
  1552.       { $t->{twig_id_list}->{$id}= $elt; 
  1553.         weaken( $t->{twig_id_list}->{$id}) if( $weakrefs);
  1554.       }
  1555.  
  1556.     # call user handler if need be
  1557.     if( $t->{twig_starttag_handlers})
  1558.       { # call all appropriate handlers
  1559.         my @handlers= _handler( $t, $t->{twig_starttag_handlers}, $gi, $elt);
  1560.     
  1561.         local $_= $elt;
  1562.     
  1563.         foreach my $handler ( @handlers)
  1564.           { $handler->($t, $elt) || last; }
  1565.         # call _all_ handler if needed
  1566.         if( my $all= $t->{twig_starttag_handlers}->{handlers}->{string}->{$ALL})
  1567.           { $all->($t, $elt); }
  1568.       }
  1569.  
  1570.     # check if the tag is in the list of tags to be ignored
  1571.     if( $t->{twig_ignore_elts_handlers})
  1572.       { my @handlers= _handler( $t, $t->{twig_ignore_elts_handlers}, $gi, $elt);
  1573.         # only the first handler counts, it contains the action (discard/print/string)
  1574.         if( @handlers) { my $action= shift @handlers; $t->ignore( $action); }
  1575.       }
  1576.  
  1577.     if( $elt->{'att'}->{'xml:space'} && (  $elt->{'att'}->{'xml:space'} eq 'preserve')) { $t->{twig_preserve_space}++; }
  1578.  
  1579.   }
  1580.  
  1581. sub _replace_ns
  1582.   { my( $t, $gi, $atts)= @_;
  1583.     foreach my $new_prefix ( $t->parser->new_ns_prefixes)
  1584.       { my $uri= $t->parser->expand_ns_prefix( $new_prefix);
  1585.         # replace the prefix if it is mapped
  1586.         if( !$t->{twig_keep_original_prefix} && (my $mapped_prefix= $t->{twig_map_xmlns}->{$uri}))
  1587.           { $new_prefix= $mapped_prefix; }
  1588.         # now put the namespace declaration back in the element
  1589.         if( $new_prefix eq '#default')
  1590.           { push @$atts, "xmlns" =>  $uri; } 
  1591.         else
  1592.           { push @$atts, "xmlns:$new_prefix" =>  $uri; } 
  1593.       }
  1594.  
  1595.     if( $t->{twig_keep_original_prefix})
  1596.       { # things become more complex: we need to find the original prefix
  1597.         # and store both prefixes
  1598.         my $ns_info= $t->_ns_info( $$gi);
  1599.         my $map_att;
  1600.         if( $ns_info->{mapped_prefix})
  1601.           { $$gi= "$ns_info->{mapped_prefix}:$$gi";
  1602.             $map_att->{$ns_info->{mapped_prefix}}= $ns_info->{prefix};
  1603.           }
  1604.         my $att_name=1;
  1605.         foreach( @$atts) 
  1606.           { if( $att_name) 
  1607.               { 
  1608.                 my $ns_info= $t->_ns_info( $_);
  1609.                 if( $ns_info->{mapped_prefix})
  1610.                   { $_= "$ns_info->{mapped_prefix}:$_";
  1611.                     $map_att->{$ns_info->{mapped_prefix}}= $ns_info->{prefix};
  1612.                   }
  1613.                 $att_name=0; 
  1614.               }
  1615.             else           
  1616.               {  $att_name=1; }
  1617.           }
  1618.         push @$atts, '#original_gi', $map_att if( $map_att);
  1619.       }
  1620.     else
  1621.       { $$gi= $t->_replace_prefix( $$gi); 
  1622.         my $att_name=1;
  1623.         foreach( @$atts) 
  1624.           { if( $att_name) { $_= $t->_replace_prefix( $_); $att_name=0; }
  1625.             else           {  $att_name=1; }
  1626.           }
  1627.       }
  1628.   }
  1629.  
  1630.  
  1631. # extract prefix, local_name, uri, mapped_prefix from a name
  1632. # will only work if called from a start or end tag handler
  1633. sub _ns_info
  1634.   { my( $t, $name)= @_;
  1635.     my $ns_info={};
  1636.     my $p= $t->parser;
  1637.     $ns_info->{uri}= $p->namespace( $name); 
  1638.     return $ns_info unless( $ns_info->{uri});
  1639.  
  1640.     $ns_info->{prefix}= _a_proper_ns_prefix( $p, $ns_info->{uri});
  1641.     $ns_info->{mapped_prefix}= $t->{twig_map_xmlns}->{$ns_info->{uri}} || $ns_info->{prefix};
  1642.  
  1643.     return $ns_info;
  1644.   }
  1645.     
  1646. sub _a_proper_ns_prefix
  1647.   { my( $p, $uri)= @_;
  1648.     foreach my $prefix ($p->current_ns_prefixes)
  1649.       { if( $p->expand_ns_prefix( $prefix) eq $uri)
  1650.           { return $prefix; }
  1651.       }
  1652.   }
  1653.  
  1654. sub _fill_default_atts
  1655.   { my( $t, $gi, $atts)= @_;
  1656.     my $dtd= $t->{twig_dtd};
  1657.     my $attlist= $dtd->{att}->{$gi};
  1658.     my %value= @$atts;
  1659.     foreach my $att (keys %$attlist)
  1660.       { if(   !exists( $value{$att}) 
  1661.             && exists( $attlist->{$att}->{default})
  1662.             && ( $attlist->{$att}->{default} ne '#IMPLIED')
  1663.           )
  1664.           { # the quotes are included in the default, so we need to remove them
  1665.             my $default_value= substr( $attlist->{$att}->{default}, 1, -1);
  1666.             push @$atts, $att, $default_value;
  1667.           }
  1668.       }
  1669.   }
  1670.  
  1671.  
  1672. # the default function to parse a start tag (in keep_encoding mode)
  1673. # can be overridden with the parse_start_tag method
  1674. # only works for 1-byte character sets
  1675. sub _parse_start_tag
  1676.   { my $string= shift;
  1677.     my( $gi, @atts);
  1678.  
  1679.     # get the gi (between < and the first space, / or > character)
  1680.     #if( $string=~ s{^<\s*([^\s>/]*)[\s>/]*}{}s)
  1681.     if( $string=~ s{^<\s*($REG_NAME)\s*[\s>/]}{}s)
  1682.       { $gi= $1; }
  1683.     else
  1684.       { croak "error parsing tag '$string'"; }
  1685.     while( $string=~ s{^([^\s=]*)\s*=\s*(["'])(.*?)\2\s*}{}s)
  1686.       { push @atts, $1, $3; }
  1687.     return $gi, @atts;
  1688.   }
  1689.  
  1690. sub set_root
  1691.   { my( $t, $elt)= @_;
  1692.     $t->{twig_root}= $elt;
  1693.     $elt->{twig}= $t;
  1694.     weaken(  $elt->{twig}) if( $weakrefs);
  1695.     return $t;
  1696.   }
  1697.  
  1698. sub _twig_end($$;@)
  1699.   { 
  1700.     my ($p, $gi)  = @_;
  1701.     my $t=$p->{twig};
  1702.  
  1703.     if( $t->{twig_map_xmlns}) { $gi= $t->_replace_prefix( $gi); }
  1704.   
  1705.     _add_or_discard_stored_spaces( $t);
  1706.  
  1707.     # the new twig_current is the parent
  1708.     my $elt= $t->{twig_current};
  1709.     delete $elt->{'twig_current'};
  1710.  
  1711.     # if we were parsing PCDATA then we exit the pcdata too
  1712.     if( $t->{twig_in_pcdata})
  1713.       { $t->{twig_in_pcdata}= 0;
  1714.         $elt= $elt->{parent} if($elt->{parent});
  1715.         delete $elt->{'twig_current'};
  1716.       }
  1717.  
  1718.     # parent is the new current element
  1719.     my $parent= $elt->{parent};
  1720.     $parent->{'twig_current'}=1 if( $parent);
  1721.     $t->{twig_current}= $parent;
  1722.  
  1723.     $elt->{extra_data_before_end_tag}= $t->{extra_data} if( $t->{extra_data}); 
  1724.     $t->{extra_data}='';
  1725.  
  1726.     if( $t->{twig_handlers})
  1727.       { # look for handlers
  1728.         my @handlers= _handler( $t, $t->{twig_handlers}, $gi, $elt);
  1729.  
  1730.         local $_= $elt; # so we can use $_ in the handlers
  1731.     
  1732.         foreach my $handler ( @handlers)
  1733.           { $handler->($t, $elt) || last; }
  1734.         # call _all_ handler if needed
  1735.         if( my $all= $t->{twig_handlers}->{handlers}->{string}->{$ALL})
  1736.           { $all->($t, $elt); }
  1737.       }
  1738.  
  1739.     # if twig_roots is set for the element then set appropriate handler
  1740.     if(  $t->{twig_root_depth} and ($p->depth == $t->{twig_root_depth}) )
  1741.       { if( $t->{twig_default_print})
  1742.           { # select the proper fh (and store the currently selected one)
  1743.             $t->_set_fh_to_twig_output_fh(); 
  1744.             if( $t->{twig_keep_encoding})
  1745.               { $p->setHandlers( %twig_handlers_roots_print_original); }
  1746.             else
  1747.               { $p->setHandlers( %twig_handlers_roots_print); }
  1748.           }
  1749.         else
  1750.           { $p->setHandlers( %twig_handlers_roots); }
  1751.       }
  1752.  
  1753.     if( $elt->{'att'}->{'xml:space'} && (  $elt->{'att'}->{'xml:space'} eq 'preserve')) { $t->{twig_preserve_space}--; }
  1754.   }
  1755.  
  1756. # return the list of handler that can be activated for an element 
  1757. # (either of CODE ref's or 1's for twig_roots)
  1758.  
  1759. sub _handler
  1760.   { my( $t, $handlers, $gi, $elt)= @_;
  1761.  
  1762.     my @found_handlers=();
  1763.     my $found_handler;
  1764.  
  1765.     # warning: $elt can be either 
  1766.     # - a regular element
  1767.     # - a ref to the attribute hash (when called for an element 
  1768.     #   for which the XML::Twig::Elt has not been built, outside 
  1769.     #   of the twig_roots)
  1770.     # - a string (case of an entity in keep_encoding mode)
  1771.  
  1772.     # check for an attribute expression with no gi
  1773.     if( $handlers->{att_handlers})
  1774.       { my %att_handlers= %{$handlers->{att_handlers_exp}};
  1775.         foreach my $att ( keys %att_handlers)
  1776.           { my $att_val;
  1777.             # get the attribute value
  1778.             if( ref $elt eq 'HASH')
  1779.               { $att_val= $elt->{$att}; }     # $elt is the atts hash
  1780.             elsif( isa( $elt,'XML::Twig::Elt'))
  1781.               { $att_val= $elt->{'att'}->{$att}; }  # $elt is an element
  1782.                 if( defined $att_val)
  1783.                   { my @cond= @{$handlers->{att_handlers_exp}->{$att}};
  1784.                     foreach my $cond (@cond)
  1785.                       {  # 2 cases: either there is a val and the att value should be equal to it
  1786.                          #          or there is no val (condition was gi[@att]), just for the att to be defined 
  1787.                     if( !defined $cond->{val} || ($att_val eq $cond->{val}) )  
  1788.                       { push @found_handlers, $cond->{handler};}
  1789.                   }
  1790.               }
  1791.           }
  1792.       }
  1793.  
  1794.     # check for an attribute regexp expression with no gi
  1795.     if( $handlers->{att_regexp_handlers})
  1796.       { my %att_handlers= %{$handlers->{att_regexp_handlers_exp}};
  1797.         foreach my $att ( keys %att_handlers)
  1798.           { my $att_val;
  1799.             # get the attribute value
  1800.             if( ref $elt eq 'HASH')
  1801.               { $att_val= $elt->{$att}; }     # $elt is the atts hash
  1802.             elsif( isa( $elt,'XML::Twig::Elt'))
  1803.               { $att_val= $elt->{'att'}->{$att}; }  # $elt is an element
  1804.  
  1805.             if( defined $att_val)
  1806.               { my @cond= @{$handlers->{att_regexp_handlers_exp}->{$att}};
  1807.                 foreach my $cond (@cond)
  1808.                   { if( $att_val=~ $cond->{regexp})  
  1809.                       { push @found_handlers, $cond->{handler};}
  1810.                   }
  1811.               }
  1812.           }
  1813.       }
  1814.  
  1815.     # check for a text expression
  1816.     if( $handlers->{text_handlers}->{$gi})
  1817.       { my @text_handlers= @{$handlers->{text_handlers_exp}->{$gi}};
  1818.         foreach my $exp ( @text_handlers)
  1819.           { if (!$exp->{sub_elt})
  1820.               { push @found_handlers, $exp->{handler}
  1821.                   if( $elt->text eq $exp->{text});
  1822.               }
  1823.             else
  1824.               { foreach my $child ($elt->children($exp->{sub_elt}))
  1825.                   { if( $child->text eq $exp->{text})
  1826.                       { push @found_handlers, $exp->{handler};
  1827.                         last;
  1828.                       }
  1829.                   }
  1830.               }
  1831.           }
  1832.       }
  1833.  
  1834.     # check for a text regexp expression
  1835.     if( $handlers->{regexp_handlers}->{$gi})
  1836.       { my @regexp_handlers= @{$handlers->{regexp_handlers_exp}->{$gi}};
  1837.         foreach my $exp ( @regexp_handlers)
  1838.           { if( !$exp->{sub_elt})
  1839.               { push @found_handlers, $exp->{handler}
  1840.                   if $elt->text =~ $exp->{regexp};
  1841.               }
  1842.             else
  1843.               { foreach my $child ($elt->children($exp->{sub_elt}))
  1844.                   { if( $child->text =~ $exp->{regexp})
  1845.                       { push @found_handlers, $exp->{handler};
  1846.                         last;
  1847.                       }
  1848.                   }
  1849.               }
  1850.           }
  1851.       }
  1852.  
  1853.     # check for an attribute expression
  1854.     if( $handlers->{attcond_handlers}->{$gi})
  1855.       { my @attcond_handlers= @{$handlers->{attcond_handlers_exp}->{$gi}};
  1856.         foreach my $exp ( @attcond_handlers)
  1857.           { my $att_val;
  1858.         # get the attribute value
  1859.         if( ref $elt eq 'HASH')
  1860.           { $att_val= $elt->{$exp->{att}}; }    # $elt is the atts hash
  1861.         else
  1862.           { $att_val= $elt->{'att'}->{$exp->{att}}; }# $elt is an element
  1863.  
  1864.         # 2 cases: either there is a val and the att value should be equal to it
  1865.         #          or there is no val (condition was gi[@att]), just for the att to be defined 
  1866.         if( defined $att_val && ( !defined $exp->{val} || ($att_val eq $exp->{val}) ) ) 
  1867.               { push @found_handlers, $exp->{handler}; }
  1868.           }
  1869.       }
  1870.  
  1871.     # check for an attribute regexp
  1872.     if( $handlers->{attregexp_handlers}->{$gi})
  1873.       { my @attregexp_handlers= @{$handlers->{attregexp_handlers_exp}->{$gi}};
  1874.         foreach my $exp ( @attregexp_handlers)
  1875.           { my $att_val;
  1876.         # get the attribute value
  1877.         if( ref $elt eq 'HASH')
  1878.           { $att_val= $elt->{$exp->{att}}; }    # $elt is the atts hash
  1879.         else
  1880.           { $att_val= $elt->{'att'}->{$exp->{att}}; }# $elt is an element
  1881.  
  1882.         if( defined $att_val && ( ($att_val=~  $exp->{regexp}) ) ) 
  1883.               { push @found_handlers, $exp->{handler}; }
  1884.           }
  1885.       }
  1886.  
  1887.     # check for a full path
  1888.     if( defined $handlers->{path_handlers}->{gi}->{$gi})
  1889.       { my $path= $t->path( $gi); 
  1890.         if( defined( $found_handler= $handlers->{path_handlers}->{string}->{$path}) )
  1891.           { push @found_handlers, $found_handler; }
  1892.       }
  1893.  
  1894.     # check for a partial path
  1895.     if( $handlers->{subpath_handlers}->{gi}->{$gi})
  1896.       { my $path= $t->path( $gi);
  1897.         while( $path)
  1898.           { # test each sub path
  1899.             if( defined( $found_handler= $handlers->{subpath_handlers}->{string}->{$path}) )
  1900.               { push @found_handlers, $found_handler; }
  1901.              $path=~ s{^[^/]*/?}{}; # remove initial gi and /
  1902.           }
  1903.       }
  1904.  
  1905.     # check for a gi (simple gi's are stored directly in the handlers field)
  1906.     if( defined $handlers->{handlers}->{gi}->{$gi})
  1907.       { push @found_handlers, $handlers->{handlers}->{gi}->{$gi}; }
  1908.  
  1909.     # check for a gi regexp
  1910.     if( defined $handlers->{handlers}->{regexp})
  1911.       { foreach my $potential (values %{$handlers->{handlers}->{regexp}})
  1912.           { if( $gi=~ $potential->{regexp})
  1913.               { push @found_handlers, $potential->{handler}; }
  1914.           }
  1915.       }
  1916.  
  1917.     if( defined $handlers->{handlers}->{level}->{$t->depth})
  1918.       { push @found_handlers, $handlers->{handlers}->{level}->{$t->depth}; }
  1919.  
  1920.  
  1921.     # if no handler found call default handler if defined
  1922.     if( !@found_handlers && defined $handlers->{handlers}->{string}->{$DEFAULT})
  1923.       { push @found_handlers, $handlers->{handlers}->{string}->{$DEFAULT}; }
  1924.  
  1925.     if( @found_handlers and $t->{twig_do_not_chain_handlers}) 
  1926.       { @found_handlers= ($found_handlers[0]); }
  1927.  
  1928.     return @found_handlers; # empty if no handler found
  1929.  
  1930.   }
  1931.  
  1932.  
  1933. sub _replace_prefix
  1934.   { my( $t, $name)= @_;
  1935.     my $p= $t->parser;
  1936.     my $uri= $p->namespace( $name);
  1937.     # try to get the namespace from default if none is found (for attributes)
  1938.     # this should probably be an option
  1939.     if( !$uri and( $name!~/^xml/)) { $uri= $p->expand_ns_prefix( '#default'); }
  1940.     if( $uri)
  1941.       { if (my $mapped_prefix= $t->{twig_map_xmlns}->{$uri})
  1942.           { return "$mapped_prefix:$name"; }
  1943.         else
  1944.           { my $prefix= _a_proper_ns_prefix( $p, $uri);
  1945.             return $prefix ? "$prefix:$name" : $name; 
  1946.           }
  1947.       }
  1948.     else
  1949.       { return $name; }
  1950.   }
  1951.  
  1952. sub _twig_char
  1953.   { 
  1954.     my ($p, $string)= @_;
  1955.     my $t=$p->{twig}; 
  1956.  
  1957.     if( $t->{twig_keep_encoding})
  1958.       { if( !$t->{twig_in_cdata})
  1959.           { $string= $p->original_string(); }
  1960.         else
  1961.           { 
  1962.             use bytes; # > 5.006
  1963.             if( length( $string) < 1024)
  1964.               { $string= $p->original_string(); }
  1965.             else
  1966.               { #warn "dodgy case";
  1967.                 # TODO original_string does not hold the entire string, but $string is wrong
  1968.                 # I believe due to a bug in XML::Parser
  1969.               }
  1970.           }
  1971.       }
  1972.  
  1973.     if( $t->{twig_input_filter})
  1974.       { $string= $t->{twig_input_filter}->( $string); }
  1975.  
  1976.     if( $t->{twig_char_handler})
  1977.       { $string= $t->{twig_char_handler}->( $string); }
  1978.  
  1979.     my $elt= $t->{twig_current};
  1980.  
  1981.     if(    $t->{twig_in_cdata})
  1982.       { # text is the continuation of a previously created cdata
  1983.         $elt->{cdata}.=  $t->{twig_stored_spaces} . $string;
  1984.       } 
  1985.     elsif( $t->{twig_in_pcdata})
  1986.       { # text is the continuation of a previously created cdata
  1987.         if( $t->{extra_data})
  1988.           { $elt->{extra_data_in_pcdata} ||=[];
  1989.             push @{$elt->{extra_data_in_pcdata}}, { text => $t->{extra_data}, offset => length( $elt->{pcdata}) };
  1990.             $t->{extra_data}='';
  1991.           }
  1992.         $elt->{pcdata}.=  $string; 
  1993.       } 
  1994.     else
  1995.       { # text is just space, which might be discarded later
  1996.         if( $string=~/\A\s*\Z/s)
  1997.           { if( $t->{extra_data})
  1998.               { # we got extra data (comment, pi), lets add the spaces to it
  1999.                 $t->{extra_data} .= $string; 
  2000.               }
  2001.             else
  2002.               { # no extra data, just store the spaces
  2003.                 $t->{twig_stored_spaces}.= $string;
  2004.               }
  2005.           } 
  2006.         else
  2007.           { my $new_elt= _insert_pcdata( $t, $t->{twig_stored_spaces}.$string);
  2008.             delete $elt->{'twig_current'};
  2009.             $new_elt->{'twig_current'}=1;
  2010.             $t->{twig_current}= $new_elt;
  2011.             $t->{twig_in_pcdata}=1;
  2012.             if( $t->{extra_data})
  2013.               { $new_elt->{extra_data_in_pcdata}=[];
  2014.                 push @{$new_elt->{extra_data_in_pcdata}}, { text => $t->{extra_data}, offset => 0 };
  2015.                 $t->{extra_data}='';
  2016.               }
  2017.           }
  2018.       }
  2019.   }
  2020.  
  2021. sub _twig_cdatastart
  2022.   { 
  2023.     my $p= shift;
  2024.     my $t=$p->{twig};
  2025.  
  2026.     $t->{twig_in_cdata}=1;
  2027.     my $cdata=  $t->{twig_elt_class}->new( '#CDATA');
  2028.     my $twig_current= $t->{twig_current};
  2029.  
  2030.     if( $t->{twig_in_pcdata})
  2031.       { # create the node as a sibling of the #PCDATA
  2032.         $cdata->set_prev_sibling( $twig_current);
  2033.         $twig_current->{next_sibling}=  $cdata;
  2034.         my $parent= $twig_current->{parent};
  2035.         $cdata->set_parent( $parent);
  2036.         $parent->set_last_child( $cdata);
  2037.         $t->{twig_in_pcdata}=0;
  2038.       }
  2039.     else
  2040.       { # we have to create a PCDATA element if we need to store spaces
  2041.         if( $t->_space_policy($XML::Twig::index2gi[$twig_current->{'gi'}]) && $t->{twig_stored_spaces})
  2042.           { _insert_pcdata( $t, $t->{twig_stored_spaces}); }
  2043.         $t->{twig_stored_spaces}='';
  2044.       
  2045.         # create the node as a child of the current element      
  2046.         $cdata->set_parent( $twig_current);
  2047.         if( my $prev_sibling= $twig_current->{last_child})
  2048.           { $cdata->set_prev_sibling( $prev_sibling);
  2049.             $prev_sibling->{next_sibling}=  $cdata;
  2050.           }
  2051.         else
  2052.           { $twig_current->{first_child}=  $cdata; }
  2053.         $twig_current->set_last_child( $cdata);
  2054.       
  2055.       }
  2056.  
  2057.     delete $twig_current->{'twig_current'};
  2058.     $t->{twig_current}= $cdata;
  2059.     $cdata->{'twig_current'}=1;
  2060.     if( $t->{extra_data}) { $cdata->set_extra_data( $t->{extra_data}); $t->{extra_data}='' };
  2061.   }
  2062.  
  2063. sub _twig_cdataend
  2064.   { 
  2065.     my $p= shift;
  2066.     my $t=$p->{twig};
  2067.  
  2068.     $t->{twig_in_cdata}=0;
  2069.  
  2070.     my $elt= $t->{twig_current};
  2071.     delete $elt->{'twig_current'};
  2072.     my $cdata= $elt->{cdata};
  2073.     $elt->_set_cdata( $cdata);
  2074.  
  2075.     if( $t->{twig_handlers})
  2076.       { # look for handlers
  2077.         my @handlers= _handler( $t, $t->{twig_handlers}, CDATA, $elt);
  2078.         local $_= $elt; # so we can use $_ in the handlers
  2079.         foreach my $handler ( @handlers) { $handler->($t, $elt) || last; }
  2080.       }
  2081.  
  2082.     $elt= $elt->{parent};
  2083.     $t->{twig_current}= $elt;
  2084.     $elt->{'twig_current'}=1;
  2085.  
  2086.     $t->{twig_long_cdata}=0;
  2087.   }
  2088.  
  2089. sub _pi_elt_handlers
  2090.   { my( $t, $pi)= @_;
  2091.     my $pi_handlers= $t->{twig_handlers}->{pi_handlers} || return;
  2092.     foreach my $handler ( $pi_handlers->{$pi->{target}}, $pi_handlers->{''})
  2093.       { if( $handler) { local $_= $pi; $handler->( $t, $pi) || last; } }
  2094.   }
  2095.  
  2096. sub _pi_text_handler
  2097.   { my( $t, $target, $data)= @_;
  2098.     if( my $handler= $t->{twig_handlers}->{pi_handlers}->{$target})
  2099.       { return $handler->( $t, $target, $data); }
  2100.     if( my $handler= $t->{twig_handlers}->{pi_handlers}->{''})
  2101.       { return $handler->( $t, $target, $data); }
  2102.     return defined( $data) && $data ne ''  ? "<?$target $data?>" : "<?$target?>" ;
  2103.   }
  2104.  
  2105. sub _comment_elt_handler
  2106.   { my( $t, $comment)= @_; 
  2107.     if( my $handler= $t->{twig_handlers}->{handlers}->{gi}->{'#COMMENT'})
  2108.       { local $_= $comment; $handler->($t, $comment); }
  2109.   }
  2110.  
  2111. sub _comment_text_handler
  2112.   { my( $t, $comment)= @_; 
  2113.     if( my $handler= $t->{twig_handlers}->{handlers}->{gi}->{'#COMMENT'})
  2114.       { $comment= $handler->($t, $comment); 
  2115.         if( !defined $comment || $comment eq '') { return ''; }
  2116.       }
  2117.     return "<!--$comment-->";
  2118.   }
  2119.  
  2120.  
  2121.  
  2122. sub _twig_comment
  2123.   { 
  2124.     my( $p, $comment_text)= @_;
  2125.     my $t=$p->{twig};
  2126.  
  2127.     if( $t->{twig_keep_encoding}) { $comment_text= substr( $p->original_string(), 4, -3); }
  2128.     
  2129.     $t->_twig_pi_comment( $p, '#COMMENT', $t->{twig_keep_comments}, $t->{twig_process_comments},
  2130.                           '_set_comment', '_comment_elt_handler', '_comment_text_handler', $comment_text
  2131.                         );
  2132.   }
  2133.  
  2134. sub _twig_pi
  2135.   { 
  2136.     my( $p, $target, $data)= @_;
  2137.     my $t=$p->{twig};
  2138.  
  2139.     if( $t->{twig_keep_encoding}) 
  2140.       { my $pi_text= substr( $p->original_string(), 2, -2); 
  2141.         ($target, $data)= split( /\s+/, $pi_text, 2);
  2142.       }
  2143.  
  2144.     $t->_twig_pi_comment( $p, '#PI', $t->{twig_keep_pi}, $t->{twig_process_pi},
  2145.                           '_set_pi', '_pi_elt_handlers', '_pi_text_handler', $target, $data
  2146.                         );
  2147.   }
  2148.  
  2149. sub _twig_pi_comment
  2150.   { my( $t, $p, $type, $keep, $process, $set, $elt_handler, $text_handler, @parser_args)= @_;
  2151.  
  2152.     if( $t->{twig_input_filter})
  2153.           { foreach my $arg (@parser_args) { $arg= $t->{twig_input_filter}->( $arg); } }
  2154.           
  2155.     # if pi/comments are to be kept then we piggiback them to the current element
  2156.     if( $keep)
  2157.       { # first add spaces
  2158.         if( $t->{twig_stored_spaces})
  2159.               { $t->{extra_data}.= $t->{twig_stored_spaces};
  2160.                 $t->{twig_stored_spaces}= '';
  2161.               }
  2162.  
  2163.         my $extra_data= $t->$text_handler( @parser_args);
  2164.         $t->{extra_data}.= $extra_data;
  2165.  
  2166.       }
  2167.     elsif( $process)
  2168.       {
  2169.         my $twig_current= $t->{twig_current}; # defined unless we are outside of the root
  2170.  
  2171.         my $elt= $t->{twig_elt_class}->new( $type);
  2172.         $elt->$set( @parser_args);
  2173.         if( $t->{extra_data}) 
  2174.           { $elt->set_extra_data( $t->{extra_data});
  2175.             $t->{extra_data}='';
  2176.           }
  2177.  
  2178.         unless( $t->root) 
  2179.           { $t->_add_cpi_outside_of_root( leading_cpi => $elt);
  2180.           }
  2181.         elsif( $t->{twig_in_pcdata})
  2182.           { # create the node as a sibling of the #PCDATA
  2183.             $elt->paste_after( $twig_current);
  2184.             $t->{twig_in_pcdata}=0;
  2185.           }
  2186.         elsif( $twig_current)
  2187.           { # we have to create a PCDATA element if we need to store spaces
  2188.             if( $t->_space_policy($XML::Twig::index2gi[$twig_current->{'gi'}]) && $t->{twig_stored_spaces})
  2189.               { _insert_pcdata( $t, $t->{twig_stored_spaces}); }
  2190.             $t->{twig_stored_spaces}='';
  2191.             # create the node as a child of the current element
  2192.             $elt->paste_last_child( $twig_current);
  2193.           }
  2194.         else
  2195.           { $t->_add_cpi_outside_of_root( trailing_cpi => $elt); }
  2196.  
  2197.         if( $twig_current)
  2198.           { delete $twig_current->{'twig_current'};
  2199.             my $parent= $elt->{parent};
  2200.             $t->{twig_current}= $parent;
  2201.             $parent->{'twig_current'}=1;
  2202.           }
  2203.  
  2204.         $t->$elt_handler( $elt);
  2205.       }
  2206.  
  2207.   }
  2208.     
  2209.  
  2210. # add a comment or pi before the first element
  2211. sub _add_cpi_outside_of_root
  2212.   { my($t, $type, $elt)= @_; # $type is 'leading_cpi' or 'trailing_cpi'
  2213.     $t->{$type} ||= $t->{twig_elt_class}->new( '#CPI');
  2214.     # create the node as a child of the current element
  2215.     $elt->paste_last_child( $t->{$type});
  2216.     return $t;
  2217.   }
  2218.   
  2219. sub _twig_final
  2220.   { 
  2221.     my $p= shift;
  2222.     my $t=$p->{twig};
  2223.  
  2224.     # store trailing data
  2225.     if( $t->{extra_data}) { $t->{trailing_cpi_text}= $t->{extra_data}; $t->{extra_data}=''; }
  2226.  
  2227.     # restore the selected filehandle if needed
  2228.     $t->_set_fh_to_selected_fh();
  2229.  
  2230.     select $t->{twig_original_selected_fh} if($t->{twig_original_selected_fh}); # probably dodgy
  2231.  
  2232.     if( exists $t->{twig_autoflush_data})
  2233.       { my @args;
  2234.         push @args,  $t->{twig_autoflush_data}->{fh}      if( $t->{twig_autoflush_data}->{fh});
  2235.         push @args,  @{$t->{twig_autoflush_data}->{args}} if( $t->{twig_autoflush_data}->{args});
  2236.         $t->flush( @args);
  2237.         delete $t->{twig_autoflush_data};
  2238.         $t->root->delete;
  2239.       }
  2240.  
  2241.     # tries to clean-up (probably not very well at the moment)
  2242.     #undef $p->{twig};
  2243.     undef $t->{twig_parser};
  2244.  
  2245.     undef $t->{twig_parsing};
  2246.  
  2247.     return $t;
  2248.   }
  2249.  
  2250. sub _insert_pcdata
  2251.   { my( $t, $string)= @_;
  2252.     # create a new #PCDATA element
  2253.     my $parent= $t->{twig_current};    # always defined
  2254.     my $elt=  $t->{twig_elt_class}->new( PCDATA);
  2255.     $elt->_set_pcdata( $string);
  2256.     my $prev_sibling= $parent->{last_child};
  2257.     if( $prev_sibling) 
  2258.       { $prev_sibling->{next_sibling}=  $elt; 
  2259.         $elt->set_prev_sibling( $prev_sibling);
  2260.       }
  2261.     else
  2262.       { $parent->{first_child}=  $elt; }
  2263.  
  2264.     $elt->set_parent( $parent);
  2265.     $parent->set_last_child( $elt);
  2266.     $t->{twig_stored_spaces}='';
  2267.     return $elt;
  2268.   }
  2269.  
  2270. sub _space_policy
  2271.   { my( $t, $gi)= @_;
  2272.     my $policy;
  2273.     $policy=0 if( $t->{twig_discard_spaces});
  2274.     $policy=1 if( $t->{twig_keep_spaces});
  2275.     $policy=1 if( $t->{twig_keep_spaces_in}
  2276.                && $t->{twig_keep_spaces_in}->{$gi});
  2277.     $policy=0 if( $t->{twig_discard_spaces_in} 
  2278.                && $t->{twig_discard_spaces_in}->{$gi});
  2279.     return $policy;
  2280.   }
  2281.  
  2282.  
  2283. sub _twig_entity($$$$$$)
  2284.   { 
  2285.     my( $p, $name, $val, $sysid, $pubid, $ndata)= @_;
  2286.     my $t=$p->{twig};
  2287.     if( $sysid && !$ndata) { $val= _slurp_uri( $sysid); }
  2288.     my $ent=XML::Twig::Entity->new( $name, $val, $sysid, $pubid, $ndata);
  2289.     $t->entity_list->add( $ent);
  2290.     if( $parser_version > 2.27) 
  2291.       { # this is really ugly, but with some versions of XML::Parser the value 
  2292.         # of the entity is not properly returned by the default handler
  2293.         my $ent_decl= $ent->text;
  2294.         if( $t->{twig_keep_encoding})
  2295.           { if( defined $ent->{val} && ($ent_decl !~ /["']/))
  2296.               { my $val=  $ent->{val};
  2297.                 $ent_decl .= $val =~ /"/ ? qq{'$val' } : qq{"$val" }; 
  2298.               }
  2299.             # for my solaris box (perl 5.6.1, XML::Parser 2.31, expat?)
  2300.             $t->{twig_doctype}->{internal}=~ s{<!ENTITY\s+$name\s+$}{substr( $ent_decl, 0, -1)}e;
  2301.           }
  2302.         $t->{twig_doctype}->{internal} .= $ent_decl 
  2303.           unless( $t->{twig_doctype}->{internal}=~ m{<!ENTITY\s+$name\s+});
  2304.       }
  2305.  
  2306.  
  2307.   }
  2308.  
  2309. sub _twig_xmldecl
  2310.   { 
  2311.     my $p= shift;
  2312.     my $t=$p->{twig};
  2313.     $t->{twig_xmldecl}||={};                 # could have been set by set_output_encoding
  2314.     $t->{twig_xmldecl}->{version}= shift;
  2315.     $t->{twig_xmldecl}->{encoding}= shift; 
  2316.     $t->{twig_xmldecl}->{standalone}= shift;
  2317.   }
  2318.  
  2319. sub _twig_doctype
  2320.   { 
  2321.     my( $p, $name, $sysid, $pub, $internal)= @_;
  2322.     my $t=$p->{twig};
  2323.     $t->{twig_doctype}||= {};                   # create 
  2324.     $t->{twig_doctype}->{name}= $name;          # always there
  2325.     $t->{twig_doctype}->{sysid}= $sysid;        #  
  2326.     $t->{twig_doctype}->{pub}= $pub;            #  
  2327.  
  2328.     # now let's try to cope with XML::Parser 2.28 and above
  2329.     if( $parser_version > 2.27)
  2330.       { @saved_default_handler= $p->setHandlers( Default     => \&_twig_store_internal_dtd,
  2331.                                                  Entity      => \&_twig_entity,
  2332.                                                );
  2333.       $p->setHandlers( DoctypeFin  => \&_twig_stop_storing_internal_dtd);
  2334.       $t->{twig_doctype}->{internal}='';
  2335.       }
  2336.     else            
  2337.       # for XML::Parser before 2.28
  2338.       { $t->{twig_doctype}->{internal}=$internal; }
  2339.  
  2340.     # now check if we want to get the DTD info
  2341.     if( $t->{twig_read_external_dtd} && $sysid)
  2342.       { # let's build a fake document with an internal DTD
  2343.         my $dtd;
  2344.         # slurp the DTD
  2345.           { open( DTD, "<$sysid") or croak "cannot open dtd file $sysid: $!";
  2346.             local $/= undef;
  2347.             $dtd= "<!DOCTYPE $name [" . <DTD> . "]><$name/>";
  2348.             close DTD;
  2349.           }
  2350.        
  2351.         $t->save_global_state();            # save the globals (they will be reset by the following new)  
  2352.         my $t_dtd= XML::Twig->new;          # create a temp twig
  2353.         $t_dtd->parse( $dtd);               # parse it
  2354.         $t->{twig_dtd}= $t_dtd->{twig_dtd}; # grab the dtd info
  2355.         #$t->{twig_dtd_is_external}=1;
  2356.         $t->entity_list->_add_list( $t_dtd->entity_list) if( $t_dtd->entity_list); # grab the entity info
  2357.         $t->restore_global_state();
  2358.       }
  2359.  
  2360.   }
  2361.  
  2362. sub _twig_element
  2363.   { 
  2364.     my( $p, $name, $model)= @_;
  2365.     my $t=$p->{twig};
  2366.     $t->{twig_dtd}||= {};                      # may create the dtd 
  2367.     $t->{twig_dtd}->{model}||= {};             # may create the model hash 
  2368.     $t->{twig_dtd}->{elt_list}||= [];          # ordered list of elements 
  2369.     push @{$t->{twig_dtd}->{elt_list}}, $name; # store the elt
  2370.     $t->{twig_dtd}->{model}->{$name}= $model;  # store the model
  2371.     if( ($parser_version > 2.27) && ($t->{twig_doctype}->{internal}=~ m{(^|>)\s*$}) ) 
  2372.       { my $text= $XML::Twig::Elt::keep_encoding ? $p->original_string : $p->recognized_string; 
  2373.         unless( $text)
  2374.           { # this version of XML::Parser does not return the text in the *_string method
  2375.             # we need to rebuild it
  2376.             $text= "<!ELEMENT $name $model>";
  2377.           }
  2378.         $t->{twig_doctype}->{internal} .= $text;
  2379.       }
  2380.   }
  2381.  
  2382. sub _twig_attlist
  2383.   { 
  2384.     my( $p, $gi, $att, $type, $default, $fixed)= @_;
  2385.     #warn "in attlist: gi: '$gi', att: '$att', type: '$type', default: '$default', fixed: '$fixed'\n";
  2386.     my $t=$p->{twig};
  2387.     $t->{twig_dtd}||= {};                      # create dtd if need be 
  2388.     $t->{twig_dtd}->{$gi}||= {};               # create elt if need be 
  2389.     #$t->{twig_dtd}->{$gi}->{att}||= {};        # create att if need be 
  2390.     if( ($parser_version > 2.27) && ($t->{twig_doctype}->{internal}=~ m{(^|>)\s*$}) ) 
  2391.       { my $text= $XML::Twig::Elt::keep_encoding ? $p->original_string : $p->recognized_string; 
  2392.         unless( $text)
  2393.           { # this version of XML::Parser does not return the text in the *_string method
  2394.             # we need to rebuild it
  2395.             my $att_decl="$att $type";
  2396.             $att_decl .= " #FIXED"   if( $fixed);
  2397.             $att_decl .= " $default" if( defined $default);
  2398.             # 2 cases: there is already an attlist on that element or not
  2399.             if( $t->{twig_dtd}->{att}->{$gi})
  2400.               { # there is already an attlist, add to it
  2401.                 $t->{twig_doctype}->{internal}=~ s{(<!ATTLIST\s*$gi )(.*?)\n?>}
  2402.                                                   { "$1$2\n" . ' ' x length( $1) . "$att_decl\n>"}es;
  2403.               }
  2404.             else
  2405.               { # create the attlist
  2406.                  $t->{twig_doctype}->{internal}.= "<!ATTLIST $gi $att_decl>"
  2407.               }
  2408.           }
  2409.       }
  2410.     $t->{twig_dtd}->{att}->{$gi}->{$att}= {} ;
  2411.     $t->{twig_dtd}->{att}->{$gi}->{$att}->{type}= $type; 
  2412.     $t->{twig_dtd}->{att}->{$gi}->{$att}->{default}= $default if( defined $default);
  2413.     $t->{twig_dtd}->{att}->{$gi}->{$att}->{fixed}= $fixed; 
  2414.   }
  2415.  
  2416. sub _twig_default
  2417.   { 
  2418.     my( $p, $string)= @_;
  2419.     
  2420.     my $t= $p->{twig};
  2421.     
  2422.     # process only if we have an entity
  2423.     return unless( $string=~ m{^&([^;]*);$});
  2424.     # the entity has to be pure pcdata, or we have a problem
  2425.     if( ($p->original_string=~ m{^<}) && ($p->original_string=~ m{>$}) ) 
  2426.       { # string is a tag, entity is in an attribute
  2427.         $t->{twig_entities_in_attribute}=1 if( $t->{twig_do_not_escape_amp_in_atts});
  2428.       }
  2429.     else
  2430.       { my $ent;
  2431.         if( $t->{twig_keep_encoding}) 
  2432.           { _twig_char( $p, $string); 
  2433.             $ent= substr( $string, 1, -1);
  2434.           }
  2435.         else
  2436.           { $ent= _twig_insert_ent( $t, $string); 
  2437.           }
  2438.  
  2439.         return $ent;
  2440.       }
  2441.   }
  2442.     
  2443. sub _twig_insert_ent
  2444.   { 
  2445.     my( $t, $string)=@_;
  2446.  
  2447.     my $twig_current= $t->{twig_current};
  2448.  
  2449.     my $ent=  $t->{twig_elt_class}->new( '#ENT');
  2450.     $ent->{ent}=  $string;
  2451.  
  2452.     _add_or_discard_stored_spaces( $t, force => 0);
  2453.     
  2454.     if( $t->{twig_in_pcdata})
  2455.       { # create the node as a sibling of the #PCDATA
  2456.  
  2457.         $ent->set_prev_sibling( $twig_current);
  2458.         $twig_current->{next_sibling}=  $ent;
  2459.         my $parent= $twig_current->{parent};
  2460.         $ent->set_parent( $parent);
  2461.         $parent->set_last_child( $ent);
  2462.         # the twig_current is now the parent
  2463.         delete $twig_current->{'twig_current'};
  2464.         $t->{twig_current}= $parent;
  2465.         # we left pcdata
  2466.         $t->{twig_in_pcdata}=0;
  2467.       }
  2468.     else
  2469.       { # create the node as a child of the current element
  2470.         $ent->set_parent( $twig_current);
  2471.         if( my $prev_sibling= $twig_current->{last_child})
  2472.           { $ent->set_prev_sibling( $prev_sibling);
  2473.             $prev_sibling->{next_sibling}=  $ent;
  2474.           }
  2475.         else
  2476.           { $twig_current->{first_child}=  $ent if( $twig_current); }
  2477.         $twig_current->set_last_child( $ent) if( $twig_current);
  2478.       }
  2479.  
  2480.     # meant to trigger entity handler, does not seem to be activated at this time
  2481.     #if( my $handler= $t->{twig_handlers}->{gi}->{'#ENT'})
  2482.     #  { local $_= $ent; $handler->( $t, $ent); }
  2483.  
  2484.     return $ent;
  2485.   }
  2486.  
  2487. sub parser
  2488.   { return $_[0]->{twig_parser}; }
  2489.  
  2490. # returns the declaration text (or a default one)
  2491. sub xmldecl
  2492.   { my $t= shift;
  2493.     return '' unless( $t->{twig_xmldecl} || $t->{output_encoding});
  2494.     my $decl_string;
  2495.     my $decl= $t->{twig_xmldecl};
  2496.     if( $decl)
  2497.       { my $version= $decl->{version};
  2498.         $decl_string= q{<?xml};
  2499.         $decl_string .= qq{ version="$version"};
  2500.  
  2501.         # encoding can either have been set (in $decl->{output_encoding})
  2502.         # or come from the document (in $decl->{encoding})
  2503.         if( $t->{output_encoding})
  2504.           { my $encoding= $t->{output_encoding};
  2505.             $decl_string .= qq{ encoding="$encoding"};
  2506.           }
  2507.         elsif( $decl->{encoding})
  2508.           { my $encoding= $decl->{encoding};
  2509.             $decl_string .= qq{ encoding="$encoding"};
  2510.           }
  2511.     
  2512.         if( defined( $decl->{standalone}))
  2513.           { $decl_string .= q{ standalone="};  
  2514.             $decl_string .= $decl->{standalone} ? "yes" : "no";  
  2515.             $decl_string .= q{"}; 
  2516.           }
  2517.       
  2518.         $decl_string .= "?>\n";
  2519.       }
  2520.     else
  2521.       { my $encoding= $t->{output_encoding};
  2522.         $decl_string= qq{<?xml version="1.0" encoding="$encoding"?>};
  2523.       }
  2524.       
  2525.     my $output_filter= XML::Twig::Elt::output_filter();
  2526.     return $output_filter ? $output_filter->( $decl_string) : $decl_string;
  2527.   }
  2528.  
  2529. # returns the doctype text (or none)
  2530. # that's the doctype just has it was in the original document
  2531. sub doctype
  2532.   { my $t= shift;
  2533.     my $doctype= $t->{twig_doctype} or return '';
  2534.     my $string= "<!DOCTYPE " . $doctype->{name};
  2535.     $string  .= qq{ SYSTEM "$doctype->{sysid}"} if( $doctype->{sysid});
  2536.     $string  .= qq{ PUBLIC  "$doctype->{pub}" } if( $doctype->{pub});
  2537.     if( $doctype->{internal})
  2538.       { # !@#$%^&* code to deal with various expat/XML::Parser versions
  2539.         $string.= " [" unless( $doctype->{internal}=~ m{^\s*\[});
  2540.         $string.= " " if( $doctype->{internal}=~ m{^\[});
  2541.         $string  .= $doctype->{internal};
  2542.         $string=~ s{\n?]?>?$}{\n]>};
  2543.       }
  2544.     else
  2545.       { $string .= ">" unless( $string=~ m{>$}); }
  2546.     return $string;
  2547.   }
  2548.  
  2549. sub set_doctype
  2550.   { my( $t, $name, $system, $public, $internal)= @_;
  2551.     $t->{twig_doctype}= {};
  2552.     my $doctype= $t->{twig_doctype};
  2553.     $doctype->{name}     = $name     if( defined $name);
  2554.     $doctype->{sysid}    = $system   if( defined $system);
  2555.     $doctype->{pub}      = $public   if( defined $public);
  2556.     $doctype->{internal} = $internal if( defined $internal);
  2557.   }
  2558.  
  2559. # return the dtd object
  2560. sub dtd
  2561.   { my $t= shift;
  2562.     return $t->{twig_dtd};
  2563.   }
  2564.  
  2565. # return an element model, or the list of element models
  2566. sub model
  2567.   { my $t= shift;
  2568.     my $elt= shift;
  2569.     return $t->dtd->{model}->{$elt} if( $elt);
  2570.     return sort keys %{$t->dtd->{model}};
  2571.   }
  2572.  
  2573.         
  2574. # return the entity_list object 
  2575. sub entity_list($)
  2576.   { my $t= shift;
  2577.     return $t->{twig_entity_list};
  2578.   }
  2579.  
  2580. # return the list of entity names 
  2581. sub entity_names($)
  2582.   { my $t= shift;
  2583.     return $t->entity_list->entity_names;
  2584.   }
  2585.  
  2586. # return the entity object 
  2587. sub entity($$)
  2588.   { my $t= shift;
  2589.     my $entity_name= shift;
  2590.     return $t->entity_list->ent( $entity_name);
  2591.   }
  2592.  
  2593.  
  2594. sub print_prolog
  2595.   { my $t= shift;
  2596.     my $fh=  _is_fh($_[0])  ? shift : $t->{twig_output_fh} || select() || \*STDOUT;
  2597.     no strict 'refs';
  2598.     print {$fh} $t->prolog( @_);
  2599.   }
  2600.  
  2601. sub prolog
  2602.   { my $t= shift;
  2603.     my %args= _normalize_args( @_);
  2604.     my $prolog='';
  2605.  
  2606.     return $prolog if( $t->{no_prolog});
  2607.  
  2608.     my $update_dtd = $args{UpdateDTD} || '';
  2609.  
  2610.     $prolog .= $t->xmldecl;
  2611.     return $prolog if( defined( $t->{no_dtd_output}));
  2612.  
  2613.     my $dtd='';
  2614.     
  2615.     my $doctype= $t->{twig_doctype};
  2616.  
  2617.     if( $doctype)
  2618.       {
  2619.         $dtd .= qq{<!DOCTYPE $doctype->{name}} if( $doctype->{name});
  2620.         $dtd .= qq{ PUBLIC "$doctype->{pub}"}  if( $doctype->{pub});
  2621.         $dtd .= qq{ SYSTEM}                    if( $doctype->{sysid} && !$doctype->{pub});
  2622.         $dtd .= qq{ "$doctype->{sysid}"}       if( $doctype->{sysid});
  2623.       }
  2624.  
  2625.     if( $update_dtd)
  2626.       { 
  2627.         if( $doctype)  
  2628.           { 
  2629.             my $internal=$doctype->{internal};
  2630.             # awfull hack, but at least it works a little better that what was there before
  2631.             if( $internal)
  2632.               { # remove entity declarations (they will be re-generated from the updated entity list)
  2633.                 $internal=~ s{<! \s* ENTITY \s+ \w+ \s+ ( ("[^"]*"|'[^']*') \s* | SYSTEM [^>]*) >\s*}{}xg;
  2634.                 $internal=~ s{^\n}{};
  2635.               }
  2636.             $internal .= $t->entity_list->text ||'' if( $t->entity_list);
  2637.             if( $internal) { $dtd .= "[\n$internal]>\n"; }
  2638.           }
  2639.         elsif( !$t->{'twig_dtd'} && keys %{$t->entity_list}) 
  2640.           { $dtd .= "<!DOCTYPE " . $t->root->gi . " [\n" . $t->entity_list->text . "\n]>"; }
  2641.         else
  2642.           { my $dtd= $t->{twig_dtd};
  2643.             $dtd .= $t->dtd_text;
  2644.           }            
  2645.       }
  2646.     elsif( $doctype)
  2647.       { 
  2648.         if( my $internal= $doctype->{internal}) 
  2649.           { # add opening and closing brackets if not already there
  2650.             # plus some spaces and newlines for a nice formating
  2651.             # I test it here because I can't remember which version of
  2652.             # XML::Parser need it or not, nor guess which one will in the
  2653.             # future, so this about the best I can do
  2654.             $internal=~ s{^\s*(\[\s*)?}{ [\n};
  2655.             $internal=~ s{\s*(\]\s*(>\s*)?)?\s*$}{\n]>\n};
  2656.             $dtd .=  $internal; 
  2657.           }
  2658.       }
  2659.       
  2660.     if( $dtd)
  2661.       {
  2662.         # terrible hack, as I can't figure out in which case the darn prolog
  2663.         # should get an extra > (depends on XML::Parser and expat versions)
  2664.         $dtd=~ s/(>\s*)*$/>\n/ if($dtd);
  2665.  
  2666.         $prolog .= $dtd;
  2667.  
  2668.         my $output_filter= XML::Twig::Elt::output_filter();
  2669.         return $output_filter ? $output_filter->( $prolog) : $prolog;
  2670.       }
  2671.     else
  2672.       { return $prolog; }
  2673.   }
  2674.  
  2675. sub _leading_cpi
  2676.   { my $t= shift;
  2677.     my $leading_cpi= $t->{leading_cpi} || return '';
  2678.     return $leading_cpi->xml_string;
  2679.   }
  2680.  
  2681. sub _trailing_cpi
  2682.   { my $t= shift;
  2683.     my $trailing_cpi= $t->{trailing_cpi} || return '';
  2684.     return $trailing_cpi->xml_string;
  2685.   }
  2686.  
  2687. sub _trailing_cpi_text
  2688.   { my $t= shift;
  2689.     return $t->{trailing_cpi_text} || '';
  2690.   }
  2691.  
  2692. sub print_to_file
  2693.   { my( $t, $filename)= (shift, shift);
  2694.     open( TWIG_PRINT_TO_FILE, ">$filename") or croak "cannot create file $filename: $!";
  2695.     $t->print( \*TWIG_PRINT_TO_FILE, @_);
  2696.     close TWIG_PRINT_TO_FILE;
  2697.     return $t;
  2698.   }
  2699.  
  2700. sub print
  2701.   { my $t= shift;
  2702.     my $fh=  _is_fh( $_[0])  ? shift : undef;
  2703.     my %args= _normalize_args( @_);
  2704.  
  2705.     if( $fh) { print {$fh} $t->sprint( %args); } else { print $t->sprint( %args); }
  2706.  
  2707.     return $t;
  2708.   }
  2709.  
  2710.  
  2711. sub flush
  2712.   { my $t= shift;
  2713.  
  2714.     return if( $t->{twig_completely_flushed});
  2715.   
  2716.     my $fh=  _is_fh( $_[0]) ? shift : undef;
  2717.     my $old_select= defined $fh ? select $fh : undef;
  2718.     my $up_to= ref $_[0] ? shift : undef;
  2719.     my %args= _normalize_args( @_);
  2720.  
  2721.     my $old_pretty;
  2722.     if( defined $args{PrettyPrint})
  2723.       { $old_pretty= $t->set_pretty_print( $args{PrettyPrint}); 
  2724.         delete $args{PrettyPrint};
  2725.       }
  2726.  
  2727.      my $old_empty_tag_style;
  2728.      if( $args{EmptyTags})
  2729.       { $old_empty_tag_style= $t->set_empty_tag_style( $args{EmptyTags}); 
  2730.         delete $args{EmptyTags};
  2731.       }
  2732.  
  2733.  
  2734.     # the "real" last element processed, as _twig_end has closed it
  2735.     my $last_elt;
  2736.     my $flush_trailing_data=0;
  2737.     if( $up_to)
  2738.       { $last_elt= $up_to; }
  2739.     elsif( $t->{twig_current})
  2740.       { $last_elt= $t->{twig_current}->_last_child; }
  2741.     else
  2742.       { $last_elt= $t->{twig_root};
  2743.         $flush_trailing_data=1;
  2744.         $t->{twig_completely_flushed}=1;
  2745.       }
  2746.  
  2747.     # flush the DTD unless it has ready flushed (ie root has been flushed)
  2748.     my $elt= $t->{twig_root};
  2749.     unless( $elt->_flushed)
  2750.       { # store flush info so we can auto-flush later
  2751.         if( $t->{twig_autoflush})
  2752.           { $t->{twig_autoflush_data}={};
  2753.             $t->{twig_autoflush_data}->{fh}   = $fh  if( $fh);
  2754.             $t->{twig_autoflush_data}->{args} = \@_  if( @_);
  2755.           }
  2756.         $t->print_prolog( %args); 
  2757.         print $t->_leading_cpi;
  2758.       }
  2759.  
  2760.     while( $elt)
  2761.       { my $next_elt; 
  2762.         if( $last_elt && $last_elt->in( $elt))
  2763.           { 
  2764.             unless( $elt->_flushed) 
  2765.               { # just output the front tag
  2766.                 print $elt->start_tag();
  2767.                 $elt->_set_flushed;
  2768.               }
  2769.             $next_elt= $elt->{first_child};
  2770.           }
  2771.         else
  2772.           { # an element before the last one or the last one,
  2773.             $next_elt= $elt->{next_sibling};  
  2774.             $elt->_flush();
  2775.             $elt->delete; 
  2776.             last if( $last_elt && ($elt == $last_elt));
  2777.           }
  2778.         $elt= $next_elt;
  2779.       }
  2780.  
  2781.     if( $flush_trailing_data)
  2782.       { print $t->_trailing_cpi        # trailing comments and pi's (elements, in 'process' mode)
  2783.             , $t->_trailing_cpi_text   # trailing comments and pi's (in 'keep' mode)
  2784.       }
  2785.  
  2786.     select $old_select if( defined $old_select);
  2787.     $t->set_pretty_print( $old_pretty) if( defined $old_pretty); 
  2788.     $t->set_empty_tag_style( $old_empty_tag_style) if( defined $old_empty_tag_style); 
  2789.  
  2790.     return $t;
  2791.   }
  2792.  
  2793.  
  2794. # flushes up to an element
  2795. # this method just reorders the arguments and calls flush
  2796. sub flush_up_to
  2797.   { my $t= shift;
  2798.     my $up_to= shift;
  2799.     if( _is_fh( $_[0]))
  2800.       { my $fh=  shift;
  2801.         $t->flush( $fh, $up_to, @_);
  2802.       }
  2803.     else
  2804.       { $t->flush( $up_to, @_); }
  2805.  
  2806.     return $t;
  2807.   }
  2808.  
  2809.     
  2810. # same as print except the entire document text is returned as a string
  2811. sub sprint
  2812.   { my $t= shift;
  2813.     my %args= _normalize_args( @_);
  2814.  
  2815.     my $old_pretty;
  2816.     if( defined $args{PrettyPrint})
  2817.       { $old_pretty= $t->set_pretty_print( $args{PrettyPrint}); 
  2818.         delete $args{PrettyPrint};
  2819.       }
  2820.  
  2821.      my $old_empty_tag_style;
  2822.      if( defined $args{EmptyTags})
  2823.       { $old_empty_tag_style= $t->set_empty_tag_style( $args{EmptyTags}); 
  2824.         delete $args{EmptyTags};
  2825.       }
  2826.       
  2827.     my $string=   $t->prolog( %args)       # xml declaration and doctype
  2828.                 . $t->_leading_cpi( %args) # leading comments and pi's in 'process' mode
  2829.                 . $t->{twig_root}->sprint  
  2830.                 . $t->_trailing_cpi        # trailing comments and pi's (elements, in 'process' mode)
  2831.                 . $t->_trailing_cpi_text   # trailing comments and pi's (in 'keep' mode)
  2832.                 ;
  2833.  
  2834.     $t->set_pretty_print( $old_pretty) if( defined $old_pretty); 
  2835.     $t->set_empty_tag_style( $old_empty_tag_style) if( defined $old_empty_tag_style); 
  2836.  
  2837.     return $string;
  2838.   }
  2839.     
  2840.  
  2841. # this method discards useless elements in a tree
  2842. # it does the same thing as a flush except it does not print it
  2843. # the second argument is an element, the last purged element
  2844. # (this argument is usually set through the purge_up_to method)
  2845. sub purge
  2846.   { my $t= shift;
  2847.     my $up_to= shift;
  2848.  
  2849.     # the "real" last element processed, as _twig_end has closed it
  2850.     my $last_elt;
  2851.     if( $up_to)
  2852.       { $last_elt= $up_to; }
  2853.     elsif( $t->{twig_current})
  2854.       { $last_elt= $t->{twig_current}->_last_child; }
  2855.     else
  2856.       { $last_elt= $t->{twig_root}; }
  2857.     
  2858.     my $elt= $t->{twig_root};
  2859.  
  2860.     while( $elt)
  2861.       { my $next_elt; 
  2862.         if( $last_elt && $last_elt->in( $elt))
  2863.           { $elt->_set_flushed;
  2864.             $next_elt= $elt->{first_child};
  2865.           }
  2866.         else
  2867.           { # an element before the last one or the last one,
  2868.             $next_elt= $elt->{next_sibling};  
  2869.             $elt->delete; 
  2870.             last if( $last_elt && ($elt == $last_elt) );
  2871.           }
  2872.         $elt= $next_elt;
  2873.       }
  2874.  
  2875.     return $t;
  2876.   }
  2877.     
  2878. # flushes up to an element. This method just calls purge
  2879. sub purge_up_to
  2880.   { my $t= shift;
  2881.     $t->purge( @_);
  2882.   }
  2883.  
  2884. sub root
  2885.   { return $_[0]->{twig_root}; }
  2886.  
  2887. # create accessor methods on attribute names
  2888. sub create_accessors
  2889.   { 
  2890.     croak "cannot use the create_accessors method with perl 5.005" if( $] < 5.006);
  2891.  
  2892.     my $twig_or_class= shift;
  2893.     my $elt_class= ref $twig_or_class ? $twig_or_class->{twig_elt_class}
  2894.                                       : 'XML::Twig::Elt'
  2895.                                       ;
  2896.     no strict 'refs';
  2897.     foreach my $att (@_)
  2898.       { croak "attempt to redefine existing method $att using create_accessors"
  2899.           if( $elt_class->can( $att));
  2900.  
  2901.         *{"$elt_class\::$att"}=                          # > 5.006
  2902.             sub :lvalue                                  # > 5.006
  2903.               { my $elt= shift;                          # > 5.006
  2904.                 if( @_) { $elt->{att}->{$att}= $_[0]; }  # > 5.006
  2905.                 $elt->{att}->{$att};                     # > 5.006
  2906.               };                                         # > 5.006
  2907.      }
  2908.   }
  2909.  
  2910.  
  2911. #start-extract twig_document (used to generate XML::(DOM|GDOME)::Twig)
  2912. sub first_elt
  2913.   { my( $t, $cond)= @_;
  2914.     my $root= $t->root || return undef;
  2915.     return $root if( $root->passes( $cond));
  2916.     return $root->next_elt( $cond); 
  2917.   }
  2918.  
  2919. sub last_elt
  2920.   { my( $t, $cond)= @_;
  2921.     my $root= $t->root || return undef;
  2922.     return $root->last_descendant( $cond); 
  2923.   }
  2924.  
  2925. sub next_n_elt
  2926.   { my( $t, $offset, $cond)= @_;
  2927.     $offset -- if( $t->root->matches( $cond) );
  2928.     return $t->root->next_n_elt( $offset, $cond);
  2929.   }
  2930.  
  2931. sub get_xpath
  2932.   { my $twig= shift;
  2933.     if( isa( $_[0], 'ARRAY'))
  2934.       { my $elt_array= shift;
  2935.         return _unique_elts( map { $_->get_xpath( @_) } @$elt_array);
  2936.       }
  2937.     else
  2938.       { return $twig->root->get_xpath( @_); }
  2939.   }
  2940.  
  2941. # get a list of elts and return a sorted list of unique elts
  2942. sub _unique_elts
  2943.   { my @sorted= sort { $a ->cmp( $b) } @_;
  2944.     my @unique;
  2945.     while( my $current= shift @sorted)
  2946.       { push @unique, $current unless( @unique && ($unique[-1] == $current)); }
  2947.     return @unique;
  2948.   }
  2949.  
  2950. sub findvalue
  2951.   { my $twig= shift;
  2952.     if( isa( $_[0], 'ARRAY'))
  2953.       { my $elt_array= shift;
  2954.         return join( '', map { $_->findvalue( @_) } @$elt_array);
  2955.       }
  2956.     else
  2957.       { return $twig->root->findvalue( @_); }
  2958.   }
  2959.  
  2960. sub set_id_seed
  2961.   { my $t= shift;
  2962.     XML::Twig::Elt->set_id_seed( @_);
  2963.   }
  2964.  
  2965. # return an array ref to an index, or undef
  2966. sub index
  2967.   { my( $twig, $name, $index)= @_;
  2968.     return defined( $index) ? $twig->{_twig_index}->{$name}->[$index] : $twig->{_twig_index}->{$name};
  2969.   }
  2970.  
  2971. # return a list with just the root
  2972. # if a condition is given then return an empty list unless the root matches
  2973. sub children
  2974.   { my( $t, $cond)= @_;
  2975.     my $root= $t->root;
  2976.     unless( $cond && !($root->passes( $cond)) )
  2977.       { return ($root); }
  2978.     else
  2979.       { return (); }
  2980.   }
  2981.   
  2982. sub _children { return ($_[0]->root); }
  2983.  
  2984. # weird, but here for completude
  2985. # used to solve (non-sensical) /doc[1] XPath queries
  2986. sub child
  2987.   { my $t= shift;
  2988.     my $nb= shift;
  2989.     return ($t->children( @_))[$nb];
  2990.   }
  2991.  
  2992. sub descendants
  2993.   { my( $t, $cond)= @_;
  2994.     my $root= $t->root;
  2995.     if( $root->passes( $cond) )
  2996.       { return ($root, $root->descendants( $cond)); }
  2997.     else
  2998.       { return ( $root->descendants( $cond)); }
  2999.   }
  3000.  
  3001. sub simplify  { my $t= shift; $t->root->simplify( @_);  }
  3002. sub subs_text { my $t= shift; $t->root->subs_text( @_); }
  3003. sub trim      { my $t= shift; $t->root->trim( @_);      }
  3004.  
  3005. #end-extract twig_document
  3006.  
  3007. sub set_keep_encoding
  3008.   { return XML::Twig::Elt::set_keep_encoding( @_); }
  3009.  
  3010. sub set_expand_external_entities
  3011.   { return XML::Twig::Elt::set_expand_external_entities( @_); }
  3012.  
  3013. # WARNING: at the moment the id list is not updated reliably
  3014. sub elt_id
  3015.   { return $_[0]->{twig_id_list}->{$_[1]}; }
  3016.  
  3017. # change it in ALL twigs at the moment
  3018. sub change_gi 
  3019.   { my( $twig, $old_gi, $new_gi)= @_;
  3020.     my $index;
  3021.     return unless($index= $XML::Twig::gi2index{$old_gi});
  3022.     $XML::Twig::index2gi[$index]= $new_gi;
  3023.     delete $XML::Twig::gi2index{$old_gi};
  3024.     $XML::Twig::gi2index{$new_gi}= $index;
  3025.   }
  3026.  
  3027.  
  3028. # builds the DTD from the stored (possibly updated) data
  3029. sub dtd_text
  3030.   { my $t= shift;
  3031.     my $dtd= $t->{twig_dtd};
  3032.     my $doctype= $t->{twig_doctype} or return '';
  3033.     my $string= "<!DOCTYPE ".$doctype->{name};
  3034.  
  3035.     $string .= " [\n";
  3036.  
  3037.     foreach my $gi (@{$dtd->{elt_list}})
  3038.       { $string.= "<!ELEMENT $gi ".$dtd->{model}->{$gi}.">\n" ;
  3039.         if( $dtd->{att}->{$gi})
  3040.           { my $attlist= $dtd->{att}->{$gi};
  3041.             $string.= "<!ATTLIST $gi\n";
  3042.             foreach my $att ( sort keys %{$attlist})
  3043.               { 
  3044.                 if( $attlist->{$att}->{fixed})
  3045.                   { $string.= "   $att $attlist->{$att}->{type} #FIXED $attlist->{$att}->{default}"; }
  3046.                 else
  3047.                   { $string.= "   $att $attlist->{$att}->{type} $attlist->{$att}->{default}"; }
  3048.                 $string.= "\n";
  3049.               }
  3050.             $string.= ">\n";
  3051.           }
  3052.       }
  3053.     $string.= $t->entity_list->text if( $t->entity_list);
  3054.     $string.= "\n]>\n";
  3055.     return $string;
  3056.   }
  3057.         
  3058. # prints the DTD from the stored (possibly updated) data
  3059. sub dtd_print
  3060.   { my $t= shift;
  3061.     my $fh=  _is_fh( $_[0])  ? shift : undef;
  3062.     if( $fh) { print $fh $t->dtd_text; }
  3063.     else     { print $t->dtd_text;     }
  3064.   }
  3065.  
  3066. # build the subs that call directly expat
  3067. BEGIN
  3068.   { my @expat_methods= qw( depth in_element within_element context
  3069.                            current_line current_column current_byte
  3070.                            recognized_string original_string 
  3071.                            xpcroak xpcarp 
  3072.                            xml_escape
  3073.                            base current_element element_index 
  3074.                            position_in_context);
  3075.     foreach my $method (@expat_methods)
  3076.       { no strict 'refs';
  3077.         *{$method}= sub { my $t= shift;
  3078.                           croak "calling $method after parsing is finished" 
  3079.                                  unless( $t->{twig_parsing}); 
  3080.                           return $t->{twig_parser}->$method(@_); 
  3081.                         };
  3082.       }
  3083.   }
  3084.  
  3085. sub path
  3086.   { my( $t, $gi)= @_;
  3087.     if( $t->{twig_map_xmlns})
  3088.       { return "/" . join( "/", map { $t->_replace_prefix( $_)} ($t->{twig_parser}->context, $gi)); }
  3089.     else
  3090.       { return "/" . join( "/", ($t->{twig_parser}->context, $gi)); }
  3091.   }
  3092.  
  3093. sub finish
  3094.   { my $t= shift;
  3095.     return $t->{twig_parser}->finish;
  3096.   }
  3097.  
  3098. # just finish the parse by printing the rest of the document
  3099. sub finish_print
  3100.   { my( $t, $fh)= @_;
  3101.     my $old_fh;
  3102.     unless( defined $fh)
  3103.       { $t->_set_fh_to_twig_output_fh(); }
  3104.     elsif( defined $fh)
  3105.       { $old_fh= select $fh; 
  3106.         $t->{twig_original_selected_fh}= $old_fh if( $old_fh); 
  3107.       }
  3108.     
  3109.     my $p=$t->{twig_parser};
  3110.     if( $t->{twig_keep_encoding})
  3111.       { $p->setHandlers( %twig_handlers_finish_print); }
  3112.     else
  3113.       { $p->setHandlers( %twig_handlers_finish_print_original); }
  3114.   }
  3115.  
  3116. sub set_remove_cdata { return XML::Twig::Elt::set_remove_cdata( @_); }
  3117.  
  3118. sub output_filter     { return XML::Twig::Elt::output_filter( @_);     }
  3119. sub set_output_filter { return XML::Twig::Elt::set_output_filter( @_); }
  3120.  
  3121. sub output_text_filter { return XML::Twig::Elt::output_text_filter( @_); }
  3122. sub set_output_text_filter { return XML::Twig::Elt::set_output_text_filter( @_); }
  3123.  
  3124. sub set_input_filter
  3125.   { my( $t, $input_filter)= @_;
  3126.     my $old_filter= $t->{twig_input_filter};
  3127.       if( !$input_filter || isa( $input_filter, 'CODE') )
  3128.         { $t->{twig_input_filter}= $input_filter; }
  3129.       elsif( $input_filter eq 'latin1')
  3130.         {  $t->{twig_input_filter}= latin1(); }
  3131.       elsif( $filter{$input_filter})
  3132.         {  $t->{twig_input_filter}= $filter{$input_filter}; }
  3133.       else
  3134.         { croak "invalid input filter: $input_filter"; }
  3135.       
  3136.       return $old_filter;
  3137.     }
  3138.  
  3139. sub set_empty_tag_style
  3140.   { return XML::Twig::Elt::set_empty_tag_style( @_); }
  3141.  
  3142. sub set_pretty_print
  3143.   { return XML::Twig::Elt::set_pretty_print( @_); }
  3144.  
  3145. sub set_quote
  3146.   { return XML::Twig::Elt::set_quote( @_); }
  3147.  
  3148. sub set_indent
  3149.   { return XML::Twig::Elt::set_indent( @_); }
  3150.  
  3151. sub set_keep_atts_order
  3152.   { shift; return XML::Twig::Elt::set_keep_atts_order( @_); }
  3153.  
  3154. sub keep_atts_order
  3155.   { return XML::Twig::Elt::keep_atts_order( @_); }
  3156.  
  3157. sub set_do_not_escape_amp_in_atts
  3158.   { return XML::Twig::Elt::set_do_not_escape_amp_in_atts( @_); }
  3159.  
  3160. # save and restore package globals (the ones in XML::Twig::Elt)
  3161. sub save_global_state
  3162.   { my $t= shift;
  3163.     $t->{twig_saved_state}= XML::Twig::Elt::global_state();
  3164.   }
  3165.  
  3166. sub restore_global_state
  3167.   { my $t= shift;
  3168.     XML::Twig::Elt::set_global_state( $t->{twig_saved_state});
  3169.   }
  3170.  
  3171. sub global_state
  3172.   { return XML::Twig::Elt::global_state(); }
  3173.  
  3174. sub set_global_state
  3175.   {  return XML::Twig::Elt::set_global_state( $_[1]); }
  3176.  
  3177. sub dispose
  3178.   { my $t= shift;
  3179.     $t->DESTROY;
  3180.   }
  3181.   
  3182. sub DESTROY
  3183.   { my $t= shift;
  3184.     if( $t->{twig_root} && isa(  $t->{twig_root}, 'XML::Twig')) 
  3185.       { $t->{twig_root}->delete } 
  3186.  
  3187.     # added to break circular references
  3188.     undef $t->{twig};
  3189.     undef $t->{twig_root}->{twig} if( $t->{twig_root});
  3190.     undef $t->{twig_parser};
  3191.     
  3192.     $t={}; # prevents memory leaks (especially when using mod_perl)
  3193.     undef $t;
  3194.   }        
  3195.  
  3196.  
  3197. #
  3198. #  non standard handlers
  3199. #
  3200.  
  3201. # kludge: expat 1.95.2 calls both Default AND Doctype handlers
  3202. # so if the default handler finds '<!DOCTYPE' then it must 
  3203. # unset itself (_twig_print_doctype will reset it)
  3204. sub _twig_print_check_doctype
  3205.   { 
  3206.     my $p= shift;
  3207.     my $string= $p->recognized_string();
  3208.     if( $string eq '<!DOCTYPE') 
  3209.       { $p->setHandlers( Default => undef); 
  3210.         $p->{twig}->{expat_1_95_2}=1; 
  3211.       }
  3212.     else                        
  3213.       { print $string; }
  3214.     
  3215.   }
  3216.  
  3217. sub _twig_print
  3218.   { print $_[0]->recognized_string(); }
  3219.  
  3220. # recognized_string does not seem to work for entities, go figure!
  3221. # so this handler is not used 
  3222. sub _twig_print_entity
  3223.   { my $p= shift; }
  3224.  
  3225. # kludge: expat 1.95.2 calls both Default AND Doctype handlers
  3226. # so if the default handler finds '<!DOCTYPE' then it must 
  3227. # unset itself (_twig_print_doctype will reset it)
  3228. sub _twig_print_original_check_doctype
  3229.   { 
  3230.     my $p= shift;
  3231.     my $string= $p->original_string();
  3232.     if( $string eq '<!DOCTYPE') 
  3233.       { $p->setHandlers( Default => undef); 
  3234.         $p->{twig}->{expat_1_95_2}=1; 
  3235.       }
  3236.     else                        
  3237.       { print $string; }
  3238.     
  3239.   }
  3240.  
  3241. sub _twig_print_original
  3242.   { print $_[0]->original_string(); }
  3243.  
  3244.  
  3245. sub _twig_print_original_doctype
  3246.   { 
  3247.     my(  $p, $name, $sysid, $pubid, $internal)= @_;
  3248.     if( $name)
  3249.       { # with recent versions of XML::Parser original_string does not work,
  3250.         # hence we need to rebuild the doctype declaration
  3251.         my $doctype='';
  3252.         $doctype .= qq{<!DOCTYPE $name}    if( $name);
  3253.         $doctype .=  qq{ PUBLIC  "$pubid"}  if( $pubid);
  3254.         $doctype .=  qq{ SYSTEM}            if( $sysid && !$pubid);
  3255.         $doctype .=  qq{ "$sysid"}          if( $sysid); 
  3256.         $doctype .=  qq{>} unless( $p->{twig}->{expat_1_95_2});
  3257.         print $doctype;
  3258.       }
  3259.     $p->setHandlers( Default => \&_twig_print_original);
  3260.   }
  3261.  
  3262. sub _twig_print_doctype
  3263.   { 
  3264.     my(  $p, $name, $sysid, $pubid, $internal)= @_;
  3265.     if( $name)
  3266.       { # with recent versions of XML::Parser original_string does not work,
  3267.         # hence we need to rebuild the doctype declaration
  3268.         my $doctype='';
  3269.         $doctype .= qq{<!DOCTYPE $name}    if( $name);
  3270.         $doctype .=  qq{ PUBLIC  "$pubid"}  if( $pubid);
  3271.         $doctype .=  qq{ SYSTEM}            if( $sysid && !$pubid);
  3272.         $doctype .=  qq{ "$sysid"}          if( $sysid); 
  3273.         $doctype .=  qq{>} unless( $p->{twig}->{expat_1_95_2});
  3274.         print $doctype;
  3275.       }
  3276.     $p->setHandlers( Default => \&_twig_print_original);
  3277.   }
  3278.  
  3279.  
  3280. sub _twig_print_original_default
  3281.   { 
  3282.     my $p= shift;
  3283.     print $p->original_string();
  3284.   }
  3285.  
  3286. # account for the case where the element is empty
  3287. sub _twig_print_end_original
  3288.   { my $p= shift;
  3289.     print $p->original_string();
  3290.   }
  3291.  
  3292. sub _twig_start_check_roots
  3293.   { 
  3294.     my( $p, $gi, %att)= @_;
  3295.     my $t= $p->{twig};
  3296.  
  3297.     
  3298.     # $tag will always be true if it needs to be printed (the tag string is never empty)
  3299.     my $tag= $t->{twig_default_print} ? $t->{twig_keep_encoding} ? $p->original_string
  3300.                                                                  : $p->recognized_string
  3301.                                       : '';
  3302.     my $fh= $t->{twig_output_fh} || select() || \*STDOUT;
  3303.  
  3304.     if( _handler( $t, $t->{twig_roots}, $gi, \%att))
  3305.       { $p->setHandlers( %twig_handlers); # restore regular handlers
  3306.         $t->{twig_root_depth}= $p->depth; 
  3307.         _twig_start( $p, $gi, %att);
  3308.       }
  3309.     elsif( $p->depth == 0)
  3310.       { no strict 'refs';
  3311.         print {$fh} $tag if( $tag);
  3312.         _twig_start( $p, $gi, %att);
  3313.       }
  3314.     elsif( $t->{twig_starttag_handlers})
  3315.       { # look for start tag handlers
  3316.  
  3317.         if( $t->{twig_map_xmlns})
  3318.           { my @att= splice( @_, 2);
  3319.             _replace_ns( $t, \$gi, \@att);
  3320.             %att= @att;
  3321.           }
  3322.  
  3323.         my @handlers= _handler( $t, $t->{twig_starttag_handlers}, $gi, \%att);
  3324.         my $last_handler_res;
  3325.         foreach my $handler ( @handlers)
  3326.           { $last_handler_res= $handler->($t, $gi, %att);
  3327.             last unless $last_handler_res;
  3328.           }
  3329.         no strict 'refs';
  3330.         print {$fh} $tag if( $tag && (!@handlers || $last_handler_res));   
  3331.       }
  3332.     else
  3333.       { no strict 'refs';
  3334.         print {$fh} $tag if( $tag); 
  3335.       }  
  3336.   }
  3337.  
  3338. sub _twig_end_check_roots
  3339.   { 
  3340.     my( $p, $gi, %att)= @_;
  3341.     my $t= $p->{twig};
  3342.     # $tag can be empty (<elt/>), hence the undef and the tests for defined
  3343.     my $tag= $t->{twig_default_print} ? $t->{twig_keep_encoding} ? $p->original_string
  3344.                                                                  : $p->recognized_string
  3345.                                       : undef;
  3346.     my $fh= $t->{twig_output_fh} || select() || \*STDOUT;
  3347.     
  3348.     if( $t->{twig_endtag_handlers})
  3349.       { # look for start tag handlers
  3350.         my @handlers= _handler( $t, $t->{twig_endtag_handlers}, $gi, {});
  3351.         my $last_handler_res=1;
  3352.         foreach my $handler ( @handlers)
  3353.           { $last_handler_res= $handler->($t, $gi) || last; }
  3354.         return unless $last_handler_res;
  3355.       }
  3356.     {
  3357.       no strict 'refs';
  3358.       print {$fh} $tag if( defined( $tag));
  3359.     }
  3360.     if( $p->depth == 0)
  3361.       { _twig_end( $p, $gi);  }
  3362.   }
  3363.  
  3364. sub _twig_pi_check_roots
  3365.   { my( $p, $target, $data)= @_;
  3366.     my $t= $p->{twig};
  3367.     my $pi= $t->{twig_default_print} ? $t->{twig_keep_encoding} ? $p->original_string
  3368.                                                                 : $p->recognized_string
  3369.                                     : undef;
  3370.     my $fh= $t->{twig_output_fh} || select() || \*STDOUT;
  3371.     
  3372.     if( my $handler=    $t->{twig_handlers}->{pi_handlers}->{$target}
  3373.                      || $t->{twig_handlers}->{pi_handlers}->{''}
  3374.       )
  3375.       { # if handler is called on pi, then it needs to be processed as a regular node
  3376.         my @flags= qw( twig_process_pi twig_keep_pi);
  3377.         my @save= @{$t}{@flags}; # save pi related flags
  3378.         @{$t}{@flags}= (1, 0);   # override them, pi needs to be processed
  3379.         _twig_pi( @_);           # call handler on the pi
  3380.         @{$t}{@flags}= @save;;   # restore flag
  3381.       }
  3382.     else
  3383.       { no strict 'refs';
  3384.         print  {$fh} $pi if( defined( $pi));
  3385.       }
  3386.   }
  3387.  
  3388.  
  3389. sub _twig_ignore_start
  3390.   { 
  3391.     my( $p, $gi)= @_;
  3392.     my $t= $p->{twig};
  3393.     return unless( $gi eq $t->{twig_ignore_gi});
  3394.     $t->{twig_ignore_level}++;
  3395.     my $action= $t->{twig_ignore_action};
  3396.     if( $action eq 'print' )
  3397.       { _twig_print_original( @_); }
  3398. #    elsif( $action eq 'string' )
  3399. #      { $t->{twig_buffered_string} .= $p->original_string(); }
  3400.   }
  3401.  
  3402. sub _twig_ignore_end
  3403.   { 
  3404.     my( $p, $gi)= @_;
  3405.     my $t= $p->{twig};
  3406.  
  3407.     my $action= $t->{twig_ignore_action};
  3408.  
  3409.     if( $action eq 'print')
  3410.       { _twig_print_original( $p, $gi); }
  3411. #    elsif( $action eq 'string')
  3412. #      { $t->{twig_buffered_string} .= $p->original_string(); }
  3413.  
  3414.     return unless( $gi eq $t->{twig_ignore_gi});
  3415.  
  3416.     $t->{twig_ignore_level}--;
  3417.  
  3418.     unless( $t->{twig_ignore_level})
  3419.       { $t->{twig_ignore_elt}->delete; 
  3420.         $p->setHandlers( @{$t->{twig_saved_handlers}});
  3421.         # test for handlers
  3422.         if( $t->{twig_endtag_handlers})
  3423.           { # look for end tag handlers
  3424.             my @handlers= _handler( $t, $t->{twig_endtag_handlers}, $gi, {});
  3425.             my $last_handler_res=1;
  3426.             foreach my $handler ( @handlers)
  3427.               { $last_handler_res= $handler->($t, $gi) || last; }
  3428.           }
  3429.       };
  3430.   }
  3431.     
  3432. sub ignore
  3433.   { my $t= shift;
  3434.     my $elt;
  3435.  
  3436.     # get the element (default: current elt)
  3437.     if( $_[0] && isa( $_[0], 'XML::Twig::Elt'))
  3438.       { $elt= shift; }
  3439.     else
  3440.       { $elt = $t->{twig_current}; }
  3441.  
  3442.     $t->{twig_current}= $elt->{parent};
  3443.     $t->{twig_current}->set_twig_current;
  3444.  
  3445.     my $action= shift || 1; 
  3446.     $t->{twig_ignore_action}= $action;
  3447.  
  3448.     $t->{twig_ignore_elt}= $elt;     # save it
  3449.     $t->{twig_ignore_gi}= $XML::Twig::index2gi[$elt->{'gi'}];  # save its gi
  3450.     $t->{twig_ignore_level}++;
  3451.     my $p= $t->{twig_parser};
  3452.     my @saved_handlers= $p->setHandlers( %twig_handlers_ignore); # set handlers
  3453.     if( $action eq 'print')
  3454.       { $p->setHandlers( Default => \&_twig_print_original); }
  3455. #    elsif( $action eq 'string')
  3456. #      { # not used at the moment
  3457. #        $t->{twig_buffered_string}='';
  3458. #        $p->setHandlers( Default => \&twig_buffer_original);
  3459. #      }
  3460.  
  3461.     $t->{twig_saved_handlers}= \@saved_handlers;        # save current handlers
  3462.   }
  3463.  
  3464. # select $t->{twig_output_fh} and store the current selected fh 
  3465. sub _set_fh_to_twig_output_fh
  3466.   { my $t= shift;
  3467.     my $output_fh= $t->{twig_output_fh};
  3468.     if( $output_fh && !$t->{twig_output_fh_selected})
  3469.       { # there is an output fh
  3470.         $t->{twig_selected_fh}= select(); # store the currently selected fh
  3471.         $t->{twig_output_fh_selected}=1;
  3472.         select $output_fh;                # select the output fh for the twig
  3473.       }
  3474.   }
  3475.  
  3476. # select the fh that was stored in $t->{twig_selected_fh} 
  3477. # (before $t->{twig_output_fh} was selected)
  3478. sub _set_fh_to_selected_fh
  3479.   { my $t= shift;
  3480.     return unless( $t->{twig_output_fh});
  3481.     my $selected_fh= $t->{twig_selected_fh};
  3482.     $t->{twig_output_fh_selected}=0;
  3483.     select $selected_fh;
  3484.     return;
  3485.   }
  3486.   
  3487.  
  3488. sub encoding
  3489.   { return $_[0]->{twig_xmldecl}->{encoding} if( $_[0]->{twig_xmldecl}); }
  3490.  
  3491. sub set_encoding
  3492.   { my( $t, $encoding)= @_;
  3493.     $t->{twig_xmldecl} ||={};
  3494.     $t->set_xml_version( "1.0") unless( $t->xml_version);
  3495.     $t->{twig_xmldecl}->{encoding}= $encoding;
  3496.     return $t;
  3497.   }
  3498.  
  3499. sub output_encoding
  3500.   { return $_[0]->{output_encoding}; }
  3501.   
  3502. sub set_output_encoding
  3503.   { my( $t, $encoding)= @_;
  3504.     $t->set_output_filter( _encoding_filter( $encoding)) if( $encoding);
  3505.     return $t->{output_encoding}= $encoding;
  3506.   }
  3507.  
  3508. sub xml_version
  3509.   { return $_[0]->{twig_xmldecl}->{version} if( $_[0]->{twig_xmldecl}); }
  3510.  
  3511. sub set_xml_version
  3512.   { my( $t, $version)= @_;
  3513.     $t->{twig_xmldecl} ||={};
  3514.     return $t->{twig_xmldecl}->{version}= $version;
  3515.   }
  3516.  
  3517. sub standalone
  3518.   { return $_[0]->{twig_xmldecl}->{standalone} if( $_[0]->{twig_xmldecl}); }
  3519.  
  3520. sub set_standalone
  3521.   { my( $t, $standalone)= @_;
  3522.     $t->{twig_xmldecl} ||={};
  3523.     $t->set_xml_version( "1.0") unless( $t->xml_version);
  3524.     return $t->{twig_xmldecl}->{standalone}= $standalone;
  3525.   }
  3526.  
  3527.  
  3528. # SAX methods
  3529.  
  3530. sub toSAX1
  3531.   { croak "cannot use toSAX1 while parsing (use flush_toSAX1)" if (defined $_[0]->{twig_parser});
  3532.     shift(@_)->_toSAX(@_, \&XML::Twig::Elt::_start_tag_data_SAX1,
  3533.                           \&XML::Twig::Elt::_end_tag_data_SAX1
  3534.              ); }
  3535.  
  3536. sub toSAX2
  3537.   { croak "cannot use toSAX2 while parsing (use flush_toSAX2)" if (defined $_[0]->{twig_parser});
  3538.     shift(@_)->_toSAX(@_, \&XML::Twig::Elt::_start_tag_data_SAX2,
  3539.                           \&XML::Twig::Elt::_end_tag_data_SAX2
  3540.              ); }
  3541.  
  3542.  
  3543. sub _toSAX
  3544.   { my( $t, $handler, $start_tag_data, $end_tag_data) = @_;
  3545.  
  3546.     if( my $start_document =  $handler->can( 'start_document'))
  3547.       { $start_document->( $handler); }
  3548.     
  3549.     $t->_prolog_toSAX( $handler);
  3550.     
  3551.     $t->root->_toSAX( $handler, $start_tag_data, $end_tag_data)  if( $t->root);
  3552.     if( my $end_document =  $handler->can( 'end_document'))
  3553.       { $end_document->( $handler); }
  3554.   }
  3555.  
  3556.  
  3557. sub flush_toSAX1
  3558.   { shift(@_)->_flush_toSAX(@_, \&XML::Twig::Elt::_start_tag_data_SAX1,
  3559.                                \&XML::Twig::Elt::_end_tag_data_SAX1
  3560.              ); 
  3561.   }
  3562.  
  3563. sub flush_toSAX2
  3564.   { shift(@_)->_flush_toSAX(@_, \&XML::Twig::Elt::_start_tag_data_SAX2,
  3565.                                \&XML::Twig::Elt::_end_tag_data_SAX2
  3566.              ); 
  3567.   }
  3568.  
  3569. sub _flush_toSAX
  3570.   { my( $t, $handler, $start_tag_data, $end_tag_data)= @_;
  3571.  
  3572.     # the "real" last element processed, as _twig_end has closed it
  3573.     my $last_elt;
  3574.     if( $t->{twig_current})
  3575.       { $last_elt= $t->{twig_current}->_last_child; }
  3576.     else
  3577.       { $last_elt= $t->{twig_root}; }
  3578.  
  3579.     my $elt= $t->{twig_root};
  3580.     unless( $elt->_flushed)
  3581.       { # init unless already done (ie root has been flushed)
  3582.         if( my $start_document =  $handler->can( 'start_document'))
  3583.           { $start_document->( $handler); }
  3584.         # flush the DTD
  3585.         $t->_prolog_toSAX( $handler) 
  3586.       }
  3587.  
  3588.     while( $elt)
  3589.       { my $next_elt; 
  3590.         if( $last_elt && $last_elt->in( $elt))
  3591.           { 
  3592.             unless( $elt->_flushed) 
  3593.               { # just output the front tag
  3594.                 if( my $start_element = $handler->can( 'start_element'))
  3595.                  { if( my $tag_data= $start_tag_data->( $elt))
  3596.                      { $start_element->( $handler, $tag_data); }
  3597.                  }
  3598.                 $elt->_set_flushed;
  3599.               }
  3600.             $next_elt= $elt->{first_child};
  3601.           }
  3602.         else
  3603.           { # an element before the last one or the last one,
  3604.             $next_elt= $elt->{next_sibling};  
  3605.             $elt->_toSAX( $handler, $start_tag_data, $end_tag_data);
  3606.             $elt->delete; 
  3607.             last if( $last_elt && ($elt == $last_elt));
  3608.           }
  3609.         $elt= $next_elt;
  3610.       }
  3611.     if( !$t->{twig_parsing}) 
  3612.       { if( my $end_document =  $handler->can( 'end_document'))
  3613.           { $end_document->( $handler); }
  3614.       }
  3615.   }
  3616.  
  3617.  
  3618. sub _prolog_toSAX
  3619.   { my( $t, $handler)= @_;
  3620.     $t->_xmldecl_toSAX( $handler);
  3621.     $t->_DTD_toSAX( $handler);
  3622.   }
  3623.  
  3624. sub _xmldecl_toSAX
  3625.   { my( $t, $handler)= @_;
  3626.     my $decl= $t->{twig_xmldecl};
  3627.     my $data= { Version    => $decl->{version},
  3628.                 Encoding   => $decl->{encoding},
  3629.                 Standalone => $decl->{standalone},
  3630.           };
  3631.     if( my $xml_decl= $handler->can( 'xml_decl'))
  3632.       { $xml_decl->( $handler, $data); }
  3633.   }
  3634.                 
  3635. sub _DTD_toSAX
  3636.   { my( $t, $handler)= @_;
  3637.     my $doctype= $t->{twig_doctype};
  3638.     return unless( $doctype);
  3639.     my $data= { Name     => $doctype->{name},
  3640.                 PublicId => $doctype->{pub},
  3641.                 SystemId => $doctype->{sysid},
  3642.               };
  3643.  
  3644.     if( my $start_dtd= $handler->can( 'start_dtd'))
  3645.       { $start_dtd->( $handler, $data); }
  3646.  
  3647.     # I should call code to export the internal subset here 
  3648.     
  3649.     if( my $end_dtd= $handler->can( 'end_dtd'))
  3650.       { $end_dtd->( $handler); }
  3651.   }
  3652.  
  3653. # input/output filters
  3654.  
  3655. sub latin1 
  3656.   { local $SIG{__DIE__};
  3657.     if( _use(  'Encode'))
  3658.       { return encode_convert( 'ISO-8859-15'); }
  3659.     elsif( _use( 'Text::Iconv'))
  3660.       { return iconv_convert( 'ISO-8859-15'); }
  3661.     elsif( _use( 'Unicode::Map8') && _use( 'Unicode::String'))
  3662.       { return unicode_convert( 'ISO-8859-15'); }
  3663.     else
  3664.       { return \®exp2latin1; }
  3665.   }
  3666.  
  3667. sub _encoding_filter
  3668.   { 
  3669.       { local $SIG{__DIE__};
  3670.         my $encoding= $_[1] || $_[0];
  3671.         if( _use( 'Encode'))
  3672.           { my $sub= encode_convert( $encoding);
  3673.             return $sub;
  3674.           }
  3675.         elsif( _use( 'Text::Iconv'))
  3676.           { return iconv_convert( $encoding); }
  3677.         elsif( _use( 'Unicode::Map8') && _use( 'Unicode::String'))
  3678.           { return unicode_convert( $encoding); }
  3679.         }
  3680.     croak "Encode, Text::Iconv or Unicode::Map8 and Unicode::String need to be installed ",
  3681.           "in order to use encoding options";
  3682.   }
  3683.  
  3684. # shamelessly lifted from XML::TyePYX (works only with XML::Parse 2.27)
  3685. sub regexp2latin1
  3686.   { my $text=shift;
  3687.     $text=~s{([\xc0-\xc3])(.)}{ my $hi = ord($1);
  3688.                                 my $lo = ord($2);
  3689.                                 chr((($hi & 0x03) <<6) | ($lo & 0x3F))
  3690.                               }ge;
  3691.     return $text;
  3692.   }
  3693.  
  3694.  
  3695. sub html_encode
  3696.   { _use( 'HTML::Entities') or croak "cannot use html_encode: missing HTML::Entities";
  3697.     return HTML::Entities::encode_entities($_[0] );
  3698.   }
  3699.  
  3700. sub safe_encode
  3701.   {   my $str= shift;
  3702.       if( $] < 5.008)
  3703.         { $str =~ s{([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)}
  3704.                    {_XmlUtf8Decode($1)}egs; 
  3705.         }
  3706.       else
  3707.         { $str= encode( ascii => $str, $FB_HTMLCREF); }
  3708.       return $str;
  3709.   }
  3710.  
  3711. sub safe_encode_hex
  3712.   {   my $str= shift;
  3713.       if( $] < 5.008)
  3714.         { $str =~ s{([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)}
  3715.                    {_XmlUtf8Decode($1, 1)}egs; 
  3716.         }
  3717.       else
  3718.         { $str= encode( ascii => $str, $FB_XMLCREF); }
  3719.       return $str;
  3720.   }
  3721.  
  3722. # this one shamelessly lifted from XML::DOM
  3723. # does NOT work on 5.8.0
  3724. sub _XmlUtf8Decode
  3725.   { my ($str, $hex) = @_;
  3726.     my $len = length ($str);
  3727.     my $n;
  3728.  
  3729.     if ($len == 2)
  3730.       { my @n = unpack "C2", $str;
  3731.         $n = (($n[0] & 0x3f) << 6) + ($n[1] & 0x3f);
  3732.       }
  3733.     elsif ($len == 3)
  3734.       { my @n = unpack "C3", $str;
  3735.         $n = (($n[0] & 0x1f) << 12) + (($n[1] & 0x3f) << 6) + ($n[2] & 0x3f);
  3736.       }
  3737.     elsif ($len == 4)
  3738.       { my @n = unpack "C4", $str;
  3739.         $n = (($n[0] & 0x0f) << 18) + (($n[1] & 0x3f) << 12) 
  3740.            + (($n[2] & 0x3f) << 6) + ($n[3] & 0x3f);
  3741.       }
  3742.     elsif ($len == 1)    # just to be complete...
  3743.       { $n = ord ($str); }
  3744.     else
  3745.       { croak "bad value [$str] for _XmlUtf8Decode"; }
  3746.  
  3747.     my $char= $hex ? sprintf ("&#x%x;", $n) : "&#$n;";
  3748.     return $char;
  3749. }
  3750.  
  3751.  
  3752. sub unicode_convert
  3753.   { my $enc= $_[1] ? $_[1] : $_[0]; # so the method can be called on the twig or directly
  3754.     _use( 'Unicode::Map8') or croak "Unicode::Map8 not available, needed for encoding filter: $!";
  3755.     _use( 'Unicode::String') or croak "Unicode::String not available, needed for encoding filter: $!";
  3756.     import Unicode::String qw(utf8);
  3757.     my $sub= eval q{
  3758.             { my $cnv;
  3759.               BEGIN {  $cnv= Unicode::Map8->new($enc) 
  3760.                            or croak "Can't create converter to $enc";
  3761.                     }
  3762.               sub { return  $cnv->to8 (utf8($_[0])->ucs2); } 
  3763.             } 
  3764.                    };
  3765.     unless( $sub) { croak $@; }
  3766.     return $sub;
  3767.   }
  3768.  
  3769. sub iconv_convert
  3770.   { my $enc= $_[1] ? $_[1] : $_[0]; # so the method can be called on the twig or directly
  3771.     _use( 'Text::Iconv') or croak "Text::Iconv not available, needed for encoding filter: $!";
  3772.     my $sub= eval q{
  3773.             { my $cnv;
  3774.               BEGIN { $cnv = Text::Iconv->new( 'utf8', $enc) 
  3775.                            or croak "Can't create iconv converter to $enc";
  3776.                     }
  3777.               sub { return  $cnv->convert( $_[0]); } 
  3778.             }       
  3779.                    };
  3780.     unless( $sub)
  3781.       { if( $@=~ m{^Unsupported conversion: Invalid argument})
  3782.           { croak "Unsupported encoding: $enc"; }
  3783.         else
  3784.           { croak $@; }
  3785.       }
  3786.  
  3787.     return $sub;
  3788.   }
  3789.  
  3790. sub encode_convert
  3791.   { my $enc= $_[1] ? $_[1] : $_[0]; # so the method can be called on the twig or directly
  3792.     my $sub=  eval qq{sub { return encode( "$enc", \$_[0]); } };
  3793.     croak "can't create Encode-based filter: $@" unless( $sub);
  3794.     return $sub;
  3795.   }
  3796.  
  3797.  
  3798. # XML::XPath compatibility
  3799. sub getRootNode        { return $_[0]; }
  3800. sub getParentNode      { return undef; }
  3801. sub getChildNodes      { my @children= ($_[0]->root); return wantarray ? @children : \@children; }
  3802.  
  3803. sub _weakrefs
  3804.   { return $weakrefs; }
  3805.  
  3806. sub _dump
  3807.   { my $t= shift;
  3808.     my $dump='';
  3809.  
  3810.     $dump="document\n"; # should dump twig level data here
  3811.     $dump .= $t->root->_dump( @_) if( $t->root);
  3812.  
  3813.     return $dump;
  3814.     
  3815.   }
  3816.  
  3817. 1;
  3818.  
  3819. ######################################################################
  3820. package XML::Twig::Entity_list;
  3821. ######################################################################
  3822. *isa = \&UNIVERSAL::isa;
  3823.  
  3824. sub new
  3825.   { my $class = shift;
  3826.     my $self={ entities => {}, updated => 0};
  3827.  
  3828.     bless $self, $class;
  3829.     return $self;
  3830.  
  3831.   }
  3832.  
  3833. sub add_new_ent
  3834.   { my $ent_list= shift;
  3835.     my $ent= XML::Twig::Entity->new( @_);
  3836.     $ent_list->add( $ent);
  3837.     return $ent_list;
  3838.   }
  3839.  
  3840. sub _add_list
  3841.   { my( $ent_list, $to_add)= @_;
  3842.     my $ents_to_add= $to_add->{entities};
  3843.     return $ent_list unless( $ents_to_add && %$ents_to_add);
  3844.     @{$ent_list->{entities}}{keys %$ents_to_add}= values %$ents_to_add;
  3845.     $ent_list->{updated}=1;
  3846.     return $ent_list;
  3847.   }
  3848.  
  3849. sub add
  3850.   { my( $ent_list, $ent)= @_;
  3851.     $ent_list->{entities}->{$ent->{name}}= $ent;
  3852.     $ent_list->{updated}=1;
  3853.     return $ent_list;
  3854.   }
  3855.  
  3856. sub ent
  3857.   { my( $ent_list, $ent_name)= @_;
  3858.     return $ent_list->{entities}->{$ent_name};
  3859.   }
  3860.  
  3861. # can be called with an entity or with an entity name
  3862. sub delete
  3863.   { my $ent_list= shift;
  3864.     if( isa( ref $_[0], 'XML::Twig::Entity'))
  3865.       { # the second arg is an entity
  3866.         my $ent= shift;
  3867.         delete $ent_list->{entities}->{$ent->{name}};
  3868.       }
  3869.     else
  3870.       { # the second arg was not entity, must be a string then
  3871.         my $name= shift;
  3872.         delete $ent_list->{entities}->{$name};
  3873.       }
  3874.     $ent_list->{updated}=1;
  3875.     return $ent_list;
  3876.   }
  3877.  
  3878. sub print
  3879.   { my ($ent_list, $fh)= @_;
  3880.     my $old_select= defined $fh ? select $fh : undef;
  3881.  
  3882.     foreach my $ent_name ( sort keys %{$ent_list->{entities}})
  3883.       { my $ent= $ent_list->{entities}->{$ent_name};
  3884.         # we have to test what the entity is or un-defined entities can creep in
  3885.         $ent->print() if( isa( $ent, 'XML::Twig::Entity'));
  3886.       }
  3887.     select $old_select if( defined $old_select);
  3888.     return $ent_list;
  3889.   }
  3890.  
  3891. sub text
  3892.   { my ($ent_list)= @_;
  3893.     return join "\n", map { $ent_list->{entities}->{$_}->text} sort keys %{$ent_list->{entities}};
  3894.   }
  3895.  
  3896. # return the list of entity names 
  3897. sub entity_names($)
  3898.   { my $ent_list= shift;
  3899.     return sort keys %{$ent_list->{entities}} ;
  3900.   }
  3901.  
  3902.  
  3903. sub list
  3904.   { my ($ent_list)= @_;
  3905.     return map { $ent_list->{entities}->{$_} } sort keys %{$ent_list->{entities}};
  3906.   }
  3907.  
  3908. 1;
  3909.  
  3910. ######################################################################
  3911. package XML::Twig::Entity;
  3912. ######################################################################
  3913. *isa = \&UNIVERSAL::isa;
  3914.  
  3915. sub new
  3916.   { my( $ent, $name, $val, $sysid, $pubid, $ndata)= @_;
  3917.  
  3918.     my $self={};
  3919.  
  3920.     $self->{name}= $name;
  3921.     if( $val)
  3922.       { $self->{val}= $val; }
  3923.     else
  3924.       { $self->{sysid}= $sysid;
  3925.         $self->{pubid}= $pubid;
  3926.         $self->{ndata}= $ndata;
  3927.       }
  3928.     bless $self;
  3929.     return $self;
  3930.   }
  3931.  
  3932. sub name  { return $_[0]->{name}; }
  3933. sub val   { return $_[0]->{val}; }
  3934. sub sysid { return $_[0]->{sysid}; }
  3935. sub pubid { return $_[0]->{pubid}; }
  3936. sub ndata { return $_[0]->{ndata}; }
  3937.  
  3938. sub print
  3939.   { my ($ent, $fh)= @_;
  3940.     if( $fh) { print $fh $ent->text . "\n"; }
  3941.     else     { print $ent->text . "\n"; }
  3942.   }
  3943.  
  3944.  
  3945. sub text
  3946.   { my ($ent)= @_;
  3947.     if( exists $ent->{'val'})
  3948.       { if( $ent->{'val'}=~ /"/)
  3949.           { return "<!ENTITY $ent->{'name'} '$ent->{'val'}'>"; }
  3950.         return "<!ENTITY $ent->{'name'} \"$ent->{'val'}\">";
  3951.       }
  3952.     elsif( $ent->{'sysid'})
  3953.       { my $text= "<!ENTITY $ent->{'name'} ";
  3954.         $text .= "SYSTEM \"$ent->{'sysid'}\" " if( $ent->{'sysid'});
  3955.         $text .= "PUBLIC \"$ent->{'pubid'}\" " if( $ent->{'pubid'});
  3956.         $text .= "NDATA $ent->{'ndata'}"        if( $ent->{'ndata'});
  3957.         $text .= ">";
  3958.         return $text;
  3959.       }
  3960.   }
  3961.  
  3962.                 
  3963. 1;
  3964.  
  3965. ######################################################################
  3966. package XML::Twig::Elt;
  3967. ######################################################################
  3968. use Carp;
  3969.  
  3970. *isa = \&UNIVERSAL::isa;
  3971.  
  3972. use constant  PCDATA  => '#PCDATA'; 
  3973. use constant  CDATA   => '#CDATA'; 
  3974. use constant  PI      => '#PI'; 
  3975. use constant  COMMENT => '#COMMENT'; 
  3976. use constant  ENT     => '#ENT'; 
  3977.  
  3978. use constant  ASIS    => '#ASIS';    # pcdata elements not to be XML-escaped
  3979.  
  3980. use constant  ELT     => '#ELT'; 
  3981. use constant  TEXT    => '#TEXT'; 
  3982. use constant  EMPTY   => '#EMPTY'; 
  3983.  
  3984. use constant CDATA_START    => "<![CDATA[";
  3985. use constant CDATA_END      => "]]>";
  3986. use constant PI_START       => "<?";
  3987. use constant PI_END         => "?>";
  3988. use constant COMMENT_START  => "<!--";
  3989. use constant COMMENT_END    => "-->";
  3990.  
  3991. use constant XMLNS_URI      => 'http://www.w3.org/2000/xmlns/';
  3992. my $XMLNS_URI               = XMLNS_URI;
  3993.  
  3994.  
  3995. BEGIN
  3996.   { # set some aliases for methods
  3997.     *tag           = *gi; 
  3998.     *name          = *gi; 
  3999.     *set_tag       = *set_gi; 
  4000.     *set_name      = *set_gi; 
  4001.     *find_nodes    = *get_xpath; # as in XML::DOM
  4002.     *findnodes     = *get_xpath; # as in XML::LibXML
  4003.     *field         = *first_child_text;
  4004.     *trimmed_field = *first_child_trimmed_text;
  4005.     *is_field      = *contains_only_text;
  4006.     *is            = *passes;
  4007.     *matches       = *passes;
  4008.     *has_child     = *first_child;
  4009.     *has_children  = *first_child;
  4010.     *all_children_pass = *all_children_are;
  4011.     *all_children_match= *all_children_are;
  4012.     *getElementsByTagName= *descendants;
  4013.     *find_by_tag_name= *descendants_or_self;
  4014.     *unwrap          = *erase;
  4015.     *inner_xml       = *xml_string;
  4016.   
  4017.     *first_child_is  = *first_child_matches;
  4018.     *last_child_is   = *last_child_matches;
  4019.     *next_sibling_is = *next_sibling_matches;
  4020.     *prev_sibling_is = *prev_sibling_matches;
  4021.     *next_elt_is     = *next_elt_matches;
  4022.     *prev_elt_is     = *prev_elt_matches;
  4023.     *parent_is       = *parent_matches;
  4024.     *child_is        = *child_matches;
  4025.     *inherited_att   = *inherit_att;
  4026.  
  4027.     *sort_children_by_value= *sort_children_on_value;
  4028.  
  4029.     *has_atts= *att_nb;
  4030.  
  4031.     # imports from XML::Twig
  4032.     *_is_fh= *XML::Twig::_is_fh;
  4033.  
  4034.     # XML::XPath compatibility
  4035.     *string_value       = *text;
  4036.     *toString           = *sprint;
  4037.     *getName            = *gi;
  4038.     *getRootNode        = *twig;  
  4039.     *getNextSibling     = *_next_sibling;
  4040.     *getPreviousSibling = *_prev_sibling;
  4041.     *isElementNode      = *is_elt;
  4042.     *isTextNode         = *is_text;
  4043.     *isPI               = *is_pi;
  4044.     *isPINode           = *is_pi;
  4045.     *isProcessingInstructionNode= *is_pi;
  4046.     *isComment          = *is_comment;
  4047.     *isCommentNode      = *is_comment;
  4048.     *getTarget          = *target;
  4049.  
  4050.     # try using weak references
  4051.     # test whether we can use weak references
  4052.     { local $SIG{__DIE__};
  4053.       if( eval 'require Scalar::Util' && defined( &Scalar::Util::weaken) )
  4054.         { import Scalar::Util qw(weaken); }
  4055.       elsif( eval 'require WeakRef')
  4056.         { import WeakRef; }
  4057.     }
  4058. }
  4059.  
  4060.  
  4061. # can be called as XML::Twig::Elt->new( [[$gi, $atts, [@content]])
  4062. # - gi is an optional gi given to the element
  4063. # - $atts is a hashref to attributes for the element
  4064. # - @content is an optional list of text and elements that will
  4065. #   be inserted under the element 
  4066. sub new 
  4067.   { my $class= shift;
  4068.     $class= ref $class || $class;
  4069.     my $elt  = {};
  4070.     bless ($elt, $class);
  4071.  
  4072.     return $elt unless @_;
  4073.  
  4074.     # if a gi is passed then use it
  4075.     my $gi= shift;
  4076.     $elt->set_gi( $gi);
  4077.  
  4078.  
  4079.     my $atts= ref $_[0] eq 'HASH' ? shift : undef;
  4080.  
  4081.     if( $atts && defined $atts->{'#CDATA'})
  4082.       { delete $atts->{'#CDATA'};
  4083.  
  4084.         my $cdata= new( $class, '#CDATA', @_);
  4085.         return new( $class, $gi, $atts, $cdata);
  4086.       }
  4087.  
  4088.     if( $gi eq PCDATA)
  4089.       { if( grep { ref $_ } @_) { croak "element #PCDATA can only be created from text"; }
  4090.         $elt->_set_pcdata( join( '', @_)); 
  4091.       }
  4092.     elsif( $gi eq ENT)
  4093.       { $elt->{ent}=  shift; }
  4094.     elsif( $gi eq CDATA)
  4095.       { if( grep { ref $_ } @_) { croak "element #CDATA can only be created from text"; }
  4096.         $elt->_set_cdata( join( '', @_)); 
  4097.       }
  4098.     elsif( $gi eq COMMENT)
  4099.       { if( grep { ref $_ } @_) { croak "element #COMMENT can only be created from text"; }
  4100.         $elt->_set_comment( join( '', @_)); 
  4101.       }
  4102.     elsif( $gi eq PI)
  4103.       { if( grep { ref $_ } @_) { croak "element #PI can only be created from text"; }
  4104.         $elt->_set_pi( shift, join( '', @_));
  4105.       }
  4106.     else
  4107.       { # the rest of the arguments are the content of the element
  4108.         if( @_)
  4109.           { $elt->set_content( @_); }
  4110.         else
  4111.           { $elt->{empty}=  1;    }
  4112.       }
  4113.  
  4114.     if( $atts)
  4115.       { # the attribute hash can be used to pass the asis status 
  4116.         if( defined $atts->{'#ASIS'})  { $elt->set_asis(  $atts->{'#ASIS'} ); delete $atts->{'#ASIS'};  }
  4117.         if( defined $atts->{'#EMPTY'}) { $elt->{empty}=  $atts->{'#EMPTY'}; delete $atts->{'#EMPTY'}; }
  4118.         $elt->set_atts( $atts) if( keys %$atts);
  4119.         $elt->_set_id( $atts->{$ID}) if( $atts->{$ID});
  4120.       }
  4121.  
  4122.     return $elt;
  4123.   }
  4124.  
  4125. # this function creates an XM:::Twig::Elt from a string
  4126. # it is quite clumsy at the moment, as it just creates a
  4127. # new twig then returns its root
  4128. # there might also be memory leaks there
  4129. # additional arguments are passed to new XML::Twig
  4130. sub parse
  4131.   { my $class= shift;
  4132.     if( ref( $class)) { $class= ref( $class); }
  4133.     my $string= shift;
  4134.     my %args= @_;
  4135.     my $t= XML::Twig->new(%args);
  4136.     $t->parse( $string);
  4137.     my $elt= $t->root;
  4138.     # clean-up the node 
  4139.     delete $elt->{twig};         # get rid of the twig data
  4140.     delete $elt->{twig_current}; # better get rid of this too
  4141.     if( $t->{twig_id_list}) { $elt->{twig_id_list}= $t->{twig_id_list}; }
  4142.     return $elt;
  4143.   }
  4144.    
  4145. sub set_inner_xml
  4146.   { my( $elt, $xml)= @_;
  4147.     my $new_elt= $elt->parse( "<dummy>$xml</dummy>");
  4148.     $elt->cut_children;
  4149.     $new_elt->paste_first_child( $elt);
  4150.     $new_elt->erase;
  4151.     return $elt;
  4152.   }
  4153.   
  4154. sub set_inner_html
  4155.   { my( $elt, $html)= @_;
  4156.     my $t= XML::Twig->new->parse_html( "<html>$html</html>");
  4157.     my $new_elt= $t->root;
  4158.     if( $elt->tag eq 'head')
  4159.       { $new_elt->first_child( 'head')->unwrap;
  4160.         $new_elt->first_child( 'body')->cut;
  4161.       }
  4162.     elsif( $elt->tag ne 'html')
  4163.       { $new_elt->first_child( 'head')->cut;
  4164.         $new_elt->first_child( 'body')->unwrap;
  4165.       }
  4166.     $new_elt->cut;
  4167.     $elt->cut_children;
  4168.     $new_elt->paste_first_child( $elt);
  4169.     $new_elt->erase;
  4170.     return $elt;
  4171.   }
  4172.  
  4173. sub set_gi 
  4174.   { my ($elt, $gi)= @_;
  4175.     unless( defined $XML::Twig::gi2index{$gi})
  4176.       { # new gi, create entries in %gi2index and @index2gi
  4177.         push  @XML::Twig::index2gi, $gi;
  4178.         $XML::Twig::gi2index{$gi}= $#XML::Twig::index2gi;
  4179.       }
  4180.     $elt->{gi}= $XML::Twig::gi2index{$gi};
  4181.     return $elt; 
  4182.   }
  4183.  
  4184. sub gi  { return $XML::Twig::index2gi[$_[0]->{gi}]; }
  4185.  
  4186. sub local_name 
  4187.   { my $elt= shift;
  4188.     return _local_name( $XML::Twig::index2gi[$elt->{'gi'}]);
  4189.   }
  4190.  
  4191. sub ns_prefix
  4192.   { my $elt= shift;
  4193.     return _ns_prefix( $XML::Twig::index2gi[$elt->{'gi'}]);
  4194.   }
  4195.  
  4196. # namespace prefix for any qname (can be used for elements or attributes)
  4197. sub _ns_prefix
  4198.   { my $qname= shift;
  4199.     if( $qname=~ m{^([^:]*):})
  4200.       { return $1; }
  4201.     else
  4202.       { return( ''); } # should it be '' ?
  4203.   }
  4204.  
  4205. # local name for any qname (can be used for elements or attributes)
  4206. sub _local_name
  4207.   { my $qname= shift;
  4208.     (my $local= $qname)=~ s{^[^:]*:}{};
  4209.     return $local;
  4210.   }
  4211.  
  4212. BEGIN 
  4213.   { my %DEFAULT_NS= ( xml   => "http://www.w3.org/XML/1998/namespace",
  4214.                       xmlns => "http://www.w3.org/2000/xmlns/",
  4215.                     );
  4216.  
  4217.     #sub get_namespace
  4218.     sub namespace
  4219.       { my $elt= shift;
  4220.         my $prefix= defined $_[0] ? shift() : $elt->ns_prefix;
  4221.         my $ns_att= $prefix ? "xmlns:$prefix" : "xmlns";
  4222.         my $expanded= $DEFAULT_NS{$prefix} || $elt->inherit_att( $ns_att) || '';
  4223.         return $expanded;
  4224.       }
  4225.   }
  4226.  
  4227.  
  4228. # return #ELT for an element and #PCDATA... for others
  4229. sub get_type
  4230.   { my $gi_nb= $_[0]->{gi}; # the number, not the string
  4231.     return ELT if( $gi_nb >= $XML::Twig::SPECIAL_GI);
  4232.     return $_[0]->gi;
  4233.   }
  4234.  
  4235. # return the gi if it's a "real" element, 0 otherwise
  4236. sub is_elt
  4237.   { return $_[0]->gi if(  $_[0]->{gi} >=  $XML::Twig::SPECIAL_GI);
  4238.     return 0;
  4239.   }
  4240.  
  4241.  
  4242. sub is_pcdata
  4243.   { my $elt= shift;
  4244.     return (exists $elt->{'pcdata'});
  4245.   }
  4246.  
  4247. sub is_cdata
  4248.   { my $elt= shift;
  4249.     return (exists $elt->{'cdata'});
  4250.   }
  4251.  
  4252. sub is_pi
  4253.   { my $elt= shift;
  4254.     return (exists $elt->{'target'});
  4255.   }
  4256.  
  4257. sub is_comment
  4258.   { my $elt= shift;
  4259.     return (exists $elt->{'comment'});
  4260.   }
  4261.  
  4262. sub is_ent
  4263.   { my $elt= shift;
  4264.     return (exists $elt->{ent} || $elt->{ent_name});
  4265.   }
  4266.  
  4267.  
  4268. sub is_text
  4269.   { my $elt= shift;
  4270.     return (exists( $elt->{'pcdata'}) || (exists $elt->{'cdata'}));
  4271.   }
  4272.  
  4273. sub is_empty
  4274.   { return $_[0]->{empty} || 0; }
  4275.  
  4276. sub set_empty
  4277.   { $_[0]->{empty}= defined( $_[1]) ? $_[1] : 1; return $_[0]; }
  4278.  
  4279. sub set_not_empty
  4280.   { delete $_[0]->{empty} if( ($_[0]->{'empty'} || 0)); return $_[0]; }
  4281.  
  4282.  
  4283. sub set_asis
  4284.   { my $elt=shift;
  4285.  
  4286.     foreach my $descendant ($elt, $elt->_descendants )
  4287.       { $descendant->{asis}= 1;
  4288.         if( (exists $descendant->{'cdata'}))
  4289.           { $descendant->set_gi( PCDATA);
  4290.             $descendant->_set_pcdata( $descendant->{cdata});
  4291.           }
  4292.  
  4293.       }
  4294.     return $elt;
  4295.   }
  4296.  
  4297. sub set_not_asis
  4298.   { my $elt=shift;
  4299.     foreach my $descendant ($elt, $elt->descendants)
  4300.       { delete $descendant->{asis} if $descendant->{asis};}
  4301.     return $elt;
  4302.   }
  4303.  
  4304. sub is_asis
  4305.   { return $_[0]->{asis}; }
  4306.  
  4307. sub closed 
  4308.   { my $elt= shift;
  4309.     my $t= $elt->twig || return;
  4310.     my $curr_elt= $t->{twig_current};
  4311.     return unless( $curr_elt);
  4312.     return $curr_elt->in( $elt);
  4313.   }
  4314.  
  4315. sub set_pcdata 
  4316.   { my( $elt, $pcdata)= @_;
  4317.   
  4318.     if( $elt->{extra_data_in_pcdata})
  4319.       { _try_moving_extra_data( $elt, $pcdata);
  4320.       }
  4321.     delete $elt->{empty};
  4322.     $elt->{pcdata}= $pcdata;
  4323.     return $elt; 
  4324.   }
  4325.  
  4326. # internal, in cases where we know there is no extra_data (inlined anyway!)
  4327. sub _set_pcdata { $_[0]->{pcdata}= $_[1]; }
  4328.  
  4329. # try to figure out if we can keep the extra_data around
  4330. sub _try_moving_extra_data
  4331.   { my( $elt, $modified)=@_;
  4332.     my $initial= $elt->{pcdata};
  4333.     my $cpis= $elt->{extra_data_in_pcdata};
  4334.  
  4335.     if( (my $offset= index( $modified, $initial)) != -1) 
  4336.       { # text has been added
  4337.         foreach (@$cpis) { $_->{offset}+= $offset; }
  4338.       }
  4339.     elsif( ($offset= index( $initial, $modified)) != -1)
  4340.       { # text has been cut
  4341.         my $len= length( $modified);
  4342.         foreach my $cpi (@$cpis) { $cpi->{offset} -= $offset; }
  4343.         $elt->{extra_data_in_pcdata}= [ grep { $_->{offset} >= 0 && $_->{offset} < $len } @$cpis ];
  4344.       } 
  4345.     else
  4346.       {    _match_extra_data_words( $elt, $initial, $modified)
  4347.         || _match_extra_data_chars( $elt, $initial, $modified)
  4348.         || delete $elt->{extra_data_in_pcdata};
  4349.       }
  4350.   }
  4351.  
  4352. sub _match_extra_data_words
  4353.   { my( $elt, $initial, $modified)= @_;
  4354.     my @initial= split /\b/, $initial; 
  4355.     my @modified= split /\b/, $modified;
  4356.        
  4357.     return _match_extra_data( $elt, length( $initial), \@initial, \@modified);
  4358.   }
  4359.   
  4360. sub _match_extra_data_chars
  4361.   { my( $elt, $initial, $modified)= @_;
  4362.     my @initial= split //, $initial; 
  4363.     my @modified= split //, $modified;
  4364.        
  4365.     return _match_extra_data( $elt, length( $initial), \@initial, \@modified);
  4366.   }
  4367.  
  4368. sub _match_extra_data
  4369.   { my( $elt, $length, $initial, $modified)= @_;
  4370.         
  4371.     my $cpis= $elt->{extra_data_in_pcdata};
  4372.  
  4373.     if( @$initial <= @$modified)
  4374.       { 
  4375.         my( $ok, $positions, $offsets)= _pos_offset( $initial, $modified);
  4376.         if( $ok) 
  4377.           { my $offset=0;
  4378.             my $pos= shift @$positions;
  4379.             foreach my $cpi (@$cpis)
  4380.               { while( $cpi->{offset} >= $pos)
  4381.                   { $offset= shift @$offsets; 
  4382.                     $pos= shift @$positions || $length +1;
  4383.                   }
  4384.                 $cpi->{offset} += $offset;
  4385.               }
  4386.             return 1;
  4387.           }
  4388.       }
  4389.     else
  4390.       { my( $ok, $positions, $offsets)= _pos_offset( $modified, $initial);
  4391.         if( $ok)
  4392.           { #print STDERR "pos:    ", join( ':', @$positions), "\n",
  4393.             #             "offset: ", join( ':', @$offsets), "\n";
  4394.             my $offset=0;
  4395.             my $pos= shift @$positions;
  4396.             my $prev_pos= 0;
  4397.             
  4398.             foreach my $cpi (@$cpis)
  4399.               { while( $cpi->{offset} >= $pos)
  4400.                   { $offset= shift @$offsets;
  4401.                     $prev_pos= $pos;
  4402.                     $pos= shift @$positions || $length +1;
  4403.                   }
  4404.                 $cpi->{offset} -= $offset;
  4405.                 if( $cpi->{offset} < $prev_pos) { delete $cpi->{text}; }
  4406.               }
  4407.             $elt->{extra_data_in_pcdata}= [ grep { exists $_->{text} } @$cpis ];
  4408.             return 1;
  4409.           }
  4410.       }
  4411.     return 0;
  4412.   }
  4413.  
  4414.           
  4415. sub _pos_offset
  4416.   { my( $short, $long)= @_;
  4417.     my( @pos, @offset);
  4418.     my( $s_length, $l_length)=(0,0);
  4419.     while (@$short)
  4420.       { my $s_word= shift @$short;
  4421.         my $l_word= shift @$long;
  4422.         if( $s_word ne $l_word)
  4423.           { while( @$long && $s_word ne $l_word)
  4424.               { $l_length += length( $l_word);
  4425.                 $l_word= shift @$long;
  4426.               }
  4427.             if( !@$long && $s_word ne $l_word) { return 0; }
  4428.             push @pos, $s_length;
  4429.             push @offset, $l_length - $s_length;
  4430.           }
  4431.         my $length= length( $s_word);
  4432.         $s_length += $length;
  4433.         $l_length += $length;
  4434.       }
  4435.     return( 1, \@pos, \@offset);
  4436.   }
  4437.  
  4438. sub append_pcdata
  4439.   { delete $_[0]->{empty};
  4440.     $_[0]->{'pcdata'}.= $_[1];
  4441.     return $_[0]; 
  4442.   }
  4443.  
  4444. sub pcdata        { return $_[0]->{pcdata}; }
  4445.  
  4446.  
  4447. sub append_extra_data 
  4448.   {  $_[0]->{extra_data}.= $_[1];
  4449.      return $_[0]; 
  4450.   }
  4451.   
  4452. sub set_extra_data 
  4453.   { $_[0]->{extra_data}= $_[1];
  4454.     return $_[0]; 
  4455.   }
  4456. sub extra_data { return $_[0]->{extra_data}; }
  4457.  
  4458. sub set_target 
  4459.   { my( $elt, $target)= @_;
  4460.     $elt->{target}= $target;
  4461.     return $elt; 
  4462.   }
  4463. sub target { return $_[0]->{target}; }
  4464.  
  4465. sub set_data 
  4466.   { $_[0]->{'data'}= $_[1]; 
  4467.     return $_[0];
  4468.   }
  4469. sub data { return $_[0]->{data}; }
  4470.  
  4471. sub set_pi
  4472.   { my $elt= shift;
  4473.     unless( $elt->{gi} == $XML::Twig::gi2index{'#PI'})
  4474.       { $elt->cut_children;
  4475.         $elt->set_gi( '#PI');
  4476.       }
  4477.     return $elt->_set_pi( @_);
  4478.   }
  4479.  
  4480. sub _set_pi
  4481.   { $_[0]->{target}=  $_[1];
  4482.     $_[0]->{data}=  $_[2];
  4483.     return $_[0]; 
  4484.   }
  4485.  
  4486. sub pi_string { my $string= PI_START . $_[0]->{target};
  4487.                 my $data= $_[0]->{data};
  4488.                 if( defined( $data) && $data ne '') { $string .= " $data"; }
  4489.                 $string .= PI_END ;
  4490.                 return $string;
  4491.               }
  4492.  
  4493. sub set_comment
  4494.   { my $elt= shift;
  4495.     unless( $elt->{gi} == $XML::Twig::gi2index{'#COMMENT'})
  4496.       { $elt->cut_children;
  4497.         $elt->set_gi( '#COMMENT');
  4498.       }
  4499.     return $elt->_set_comment( @_);
  4500.   }
  4501.  
  4502. sub _set_comment   { $_[0]->{comment}= $_[1]; return $_[0]; }
  4503. sub comment        { return $_[0]->{comment}; }
  4504. sub comment_string { return COMMENT_START . $_[0]->{comment} . COMMENT_END; }
  4505.  
  4506. sub set_ent  { $_[0]->{ent}= $_[1]; return $_[0]; }
  4507. sub ent      { return $_[0]->{ent}; }
  4508. sub ent_name { return substr( $_[0]->{ent}, 1, -1);}
  4509.  
  4510. sub set_cdata 
  4511.   { my $elt= shift;
  4512.     unless( $elt->{gi} == $XML::Twig::gi2index{'#CDATA'})
  4513.       { $elt->cut_children;
  4514.         $elt->insert_new_elt( first_child => '#CDATA', @_);
  4515.         return $elt;
  4516.       }
  4517.     return $elt->_set_cdata( @_);
  4518.   }
  4519.   
  4520. sub _set_cdata 
  4521.   { delete $_[0]->{empty};
  4522.     $_[0]->{cdata}= $_[1]; 
  4523.     return $_[0];
  4524.   }
  4525.  
  4526. sub append_cdata
  4527.   { $_[0]->{cdata}.= $_[1]; 
  4528.     return $_[0];
  4529.   }
  4530. sub cdata { return $_[0]->{cdata}; }
  4531.  
  4532.  
  4533. #start-extract twig_node
  4534. sub contains_only_text
  4535.   { my $elt= shift;
  4536.     return 0 unless $elt->is_elt;
  4537.     foreach my $child ($elt->children)
  4538.       { return 0 if $child->is_elt; }
  4539.     return $elt;
  4540.   } 
  4541.   
  4542. sub contains_only
  4543.   { my( $elt, $exp)= @_;
  4544.     my @children= $elt->children;
  4545.     foreach my $child (@children)
  4546.       { return 0 unless $child->is( $exp); }
  4547.     return @children;
  4548.   } 
  4549.  
  4550. sub contains_a_single
  4551.   { my( $elt, $exp)= @_;
  4552.     my $child= $elt->{first_child} or return 0;
  4553.     return 0 unless $child->matches( $exp);
  4554.     return 0 if( $child->{next_sibling});
  4555.     return $child;
  4556.   } 
  4557.  
  4558.  
  4559.  
  4560. sub root 
  4561.   { my $elt= shift;
  4562.     while( $elt->{parent}) { $elt= $elt->{parent}; }
  4563.     return $elt;
  4564.   }
  4565. #end-extract twig_node
  4566.  
  4567. sub twig 
  4568.   { my $elt= shift;
  4569.     my $root= $elt->root;
  4570.     return $root->{twig};
  4571.   }
  4572.  
  4573.  
  4574. #start-extract twig_node
  4575.  
  4576. # returns undef or the element, depending on whether $elt passes $cond
  4577. # $cond can be
  4578. # - empty: the element passes the condition
  4579. # - ELT ('#ELT'): the element passes the condition if it is a "real" element
  4580. # - TEXT ('#TEXT'): the element passes if it is a CDATA or PCDATA element
  4581. # - a string with an XPath condition (only a subset of XPath is actually
  4582. #   supported).
  4583. # - a regexp: the element passes if its gi matches the regexp
  4584. # - a code ref: the element passes if the code, applied on the element,
  4585. #   returns true
  4586.  
  4587. my %cond_cache; # expression => coderef
  4588.  
  4589. sub reset_cond_cache { %cond_cache=(); }
  4590.  
  4591.    sub _install_cond
  4592.     { my $cond= shift;
  4593.       my $sub;
  4594.       my $test;
  4595.       my $init='';
  4596.  
  4597.       my $original_cond= $cond;
  4598.  
  4599.       my $not= ($cond=~ s{^\s*!}{}) ? '!' : '';
  4600.  
  4601.       if( ref $cond eq 'CODE') { return $cond; }
  4602.     
  4603.       if( ref $cond eq 'Regexp')
  4604.         { $test = qq{(\$_[0]->gi=~ /$cond/)}; }
  4605.       else
  4606.         { # the condition is a string
  4607.           if( $cond eq ELT)     
  4608.             { $test = qq{\$_[0]->is_elt}; }
  4609.           elsif( $cond eq TEXT) 
  4610.             { $test = qq{\$_[0]->is_text}; }
  4611.           elsif( $cond=~ m{^\s*($REG_NAME_W)\s*$}o)                  
  4612.             { # gi
  4613.               if( $1 ne '*')
  4614.                 { # 2 options, depending on whether the gi exists in gi2index
  4615.                   # start optimization
  4616.                   my $gi= $XML::Twig::gi2index{$1};
  4617.                   if( $gi)
  4618.                     { # the gi exists, use its index as a faster shortcut
  4619.                       $test = qq{ \$_[0]->{gi} eq "$XML::Twig::gi2index{$1}"};
  4620.                     }
  4621.                   else
  4622.                   # end optimization
  4623.                     { # it does not exist (but might be created later), compare the strings
  4624.                       $test = qq{ \$_[0]->gi eq "$1"}; 
  4625.                     }
  4626.                 }
  4627.               else
  4628.                 { $test = qq{ (1) } }
  4629.             }
  4630.           elsif( $cond=~ m{^\s*($REG_REGEXP)\s*$}o)
  4631.             { # /regexp/
  4632.               $test = qq{ \$_[0]->gi=~ $1 }; 
  4633.             }
  4634.           elsif( $cond=~ m{^\s*($REG_NAME_W)?\s*\[\s*(\!\s*)?\@($REG_NAME)\s*\]\s*$}o)
  4635.             { # gi[@att]
  4636.               my( $gi, $not, $att)= ($1, $2, $3);
  4637.               $not||='';
  4638.               if( $gi && ($gi ne '*'))
  4639.                 { $test = qq{    (\$_[0]->gi eq "$gi") 
  4640.                               && $not(defined \$_[0]->{'att'}->{"$att"})
  4641.                             };
  4642.                 }
  4643.               else
  4644.                 { $test = qq{ $not (defined \$_[0]->{'att'}->{"$att"})}; }
  4645.              }
  4646.           elsif( $cond=~ m{^\s*($REG_NAME_W)?\s*  # $1
  4647.                            \[\s*(-?)\s*(\d+)\s*\] #   [$2]
  4648.                            \s*$}xo
  4649.                )
  4650.             { my( $gi, $neg, $index)= ($1, $2, $3);
  4651.               my $siblings= $neg ? q{$_[0]->_next_siblings} : q{$_[0]->_prev_siblings};
  4652.               if( $gi && ($gi ne '*')) 
  4653.                 { $test= qq{((\$_[0]->gi eq "$gi") && (scalar( grep { \$_->gi eq "$gi" } $siblings) + 1 == $index))}; }
  4654.               else
  4655.                 { $test= qq{(scalar( $siblings) + 1 == $index)}; }
  4656.             }
  4657.           elsif( $cond=~ m{^\s*($REG_NAME_W)?\s*  # $1
  4658.                            \[ \s* \@($REG_NAME)   #   [@$2
  4659.                            \s*($REG_OP)\s*        #        = (or other op) $3
  4660.                           ($REG_VALUE)            #          "$4" or '$4'
  4661.                           \s*\]\s*$}xo)           #                       ]
  4662.             { # gi[@att="val"]
  4663.               my( $gi, $att, $op, $string)= ($1, $2, _op( $3), $4);
  4664.               $init= _att_err_empty_string( att => $att);
  4665.               if( $gi && ($gi ne '*'))
  4666.                 { $test = qq{ (\$_[0]->gi eq "$gi") && ( \$att $op $string) }; }
  4667.               else
  4668.                 { 
  4669.                   $test = qq{ \$att $op $string };
  4670.                 }
  4671.             }
  4672.           elsif( $cond=~ m{^\s*($REG_NAME_W)?\s*  # $1
  4673.                            \[ \s* \@($REG_NAME)   #   [@$2
  4674.                            \s*($REG_OP)\s*        #        = (or other op) $3
  4675.                            ($REG_VALUE)           #          "$4" or '$4'
  4676.                            \s*(and|or)\s*         #              and or or ($5)
  4677.                            \@($REG_NAME)          #                  @$6
  4678.                            \s*($REG_OP)\s*        #                      = (or other op) $7
  4679.                            ($REG_VALUE)           #                        "$8" or '$8'
  4680.                            \s*\]\s*$}xo)          #                       ]
  4681.             { # gi[@att1="val1" or @att2="val2"]
  4682.               my( $gi, $att1, $op1, $string1, $connector, $att2, $op2, $string2)= ($1, $2, _op( $3), $4, $5, $6, _op( $7), $8);
  4683.               $init=  _att_err_empty_string( att1 => $att1) . ";" .  _att_err_empty_string( att2 => $att2);
  4684.               if( $gi && ($gi ne '*'))
  4685.                 { $test = qq{ (\$_[0]->gi eq "$gi") && ((\$att1 $op1 $string1 ) $connector  ( \$att2 $op2 $string2 )) }; }
  4686.               else
  4687.                 { $test = qq{ ( (\$att1 $op1 $string1) $connector ( \$att2 $op2 $string2 )) }; }
  4688.             }
  4689.           elsif( $cond=~ m{^\s*\.([\w-]+)\s*$}o)
  4690.             { # .class
  4691.               my $class= $1;
  4692.               $test = qq{(\$_[0]->in_class( "$class")) }; 
  4693.             }
  4694.           elsif( $cond=~ m{^\s*($REG_NAME_W)?\s*  # $1
  4695.                            \[ \s* \@($REG_NAME)   #   [@$2
  4696.                            \s*($REG_MATCH)\s*     #        =~ or !~ ($3)
  4697.                            ($REG_REGEXP)          #           /$4/
  4698.                            \s*\]\s*$}xo)          #                ]
  4699.             { # gi[@att=~ /regexp/] or gi[@att!~/regexp/]
  4700.               my( $gi, $att, $match, $regexp)= ($1, $2, $3, $4);
  4701.               $init= _att_err_empty_string( att => $att);
  4702.               if( $gi && ($gi ne '*'))
  4703.                 { $test = qq{    (\$_[0]->gi eq "$gi") 
  4704.                               && ( (\$_[0]->{'att'}->{"$att"}||'') $match $regexp)
  4705.                             }; 
  4706.                 }
  4707.               else
  4708.                 { # *[@att=~/regexp/ or *[@att!~/regexp/
  4709.                   $test = qq{( ( \$_[0]->{'att'}->{"$att"}||'') $match $regexp) };
  4710.                 }
  4711.             }
  4712.           elsif( $cond=~ m{^\s*\@($REG_NAME)\s*$}o)
  4713.             { # @att (or !@att)
  4714.               my( $att)= ($1);
  4715.               $test = qq{ (defined \$_[0]->{'att'}->{"$att"})}; 
  4716.             }
  4717.           elsif( $cond=~ m{^\s*                   
  4718.                            \@($REG_NAME)        #   @$1
  4719.                            \s*($REG_OP)\s*      #       = (or other op) $2
  4720.                            ($REG_VALUE)         #         "$3" or '$3'
  4721.                            \s*$}xo)                                 
  4722.             { # @att="val"
  4723.               my( $att, $op, $string)= ( $1, _op( $2), $3);
  4724.               $test = qq{( (\$_[0]->{'att'}->{"$att"}||'') $op $string) };
  4725.              }
  4726.           elsif( $cond=~ m{^\s*                   
  4727.                            \@($REG_NAME)        #   @$1
  4728.                            \s*($REG_OP)\s*      #       = (or other op) $2
  4729.                            ($REG_VALUE)         #         "$3" or '$3'
  4730.                            \s*(and|or)\s*       #              and or or ($4)
  4731.                            \@($REG_NAME)        #   @$5
  4732.                            \s*($REG_OP)\s*      #       = (or other op) $6
  4733.                            ($REG_VALUE)         #         "$7" or '$7'
  4734.                            \s*$}xo)                                 
  4735.             { # @att="val"
  4736.               my( $att1, $op1, $string1, $connector, $att2, $op2, $string2 )= ( $1, _op( $2), $3, $4, $5, _op( $6), $7);
  4737.               $init=  _att_err_empty_string( att1 => $att1) . ";" .  _att_err_empty_string( att2 => $att2);
  4738.               $test = qq{ (\$att1 $op1 $string1) $connector (\$att2 $op2 $string2) };
  4739.              }
  4740.           elsif( $cond=~ m{^\s*
  4741.                            \@($REG_NAME)        #   [@$1
  4742.                            \s*(=~|!~)\s*        #        =~ or !~ ($2)
  4743.                           ($REG_REGEXP)         #           /$3/
  4744.                           \s*\s*$}xo)           #                ]
  4745.             { # @att=~ /regexp/ or @att!~/regexp/
  4746.               my( $att, $match, $regexp)= ( $1, $2, $3);
  4747.               $init= _att_err_empty_string( att => $att);
  4748.               $test = qq{\$att $match $regexp };
  4749.             }
  4750.           elsif( $cond=~ m{^\s*($REG_NAME_W)?\s*            # $1
  4751.                            \[\s*(?:text|string)(?:\(\s*\))? #   [string()
  4752.                            \s*($REG_OP)\s*                  #            = or other op ($2)
  4753.                            ($REG_VALUE)                     #              "$3" or '$3'
  4754.                            \s*\]\s*$}xo)                    #                          ]
  4755.             { # gi[string()= "val"]
  4756.               my ($gi, $op, $text)= ($1, _op( $2), $3);
  4757.               if( $gi && ($gi ne '*'))
  4758.                 { $test = qq{(\$_[0]->gi eq "$gi") && ( \$_[0]->text eq $text)}; }
  4759.               else
  4760.                 { $test = qq{ \$_[0]->text eq $text }; }
  4761.             }
  4762.           elsif( $cond=~ m{^\s*($REG_NAME_W)?\s*            # $1
  4763.                            \[\s*(?:text|string)(?:\(\s*\))? #   [string()
  4764.                            \s*($REG_MATCH)\s*               #             =~ or !~ ($2)
  4765.                            ($REG_REGEXP)                    #               /$3/
  4766.                            \s*\]\s*$}xo)                    #                   ]
  4767.             { # gi[string()=~ /regexp/]
  4768.               my( $gi, $match, $regexp)= ($1, $2, $3);
  4769.               if( $gi && ($gi ne '*'))
  4770.                 { $test = qq{(\$_[0]->gi eq "$gi") && ( \$_[0]->text $match $regexp) }; }
  4771.               else
  4772.                 { $test = qq{ \$_[0]->text $match $regexp }; }
  4773.             }
  4774.           elsif( $cond=~ m{^\s*($REG_NAME_W)?\s*            # $1
  4775.                            \[\s*(?:text|string)\s*\(\s*     #   [string(
  4776.                            ($REG_NAME)\s*\)                 #            $2)
  4777.                            \s*($REG_OP)\s*                  #                = or other op $3
  4778.                            ($REG_VALUE)                     #                  "$4" or '$4'
  4779.                            \s*\]\s*$}xo)                    #                      ]
  4780.             { # gi[string(gi2)= "text"]
  4781.               my ($gi, $gi2, $op, $text)= ($1, $2, _op($3), $4);
  4782.               $text=~ s/([{}])/\\$1/g;
  4783.               if( $gi && ($gi ne '*'))
  4784.                 { $test = qq{    (\$_[0]->gi eq "$gi") 
  4785.                               && ( \$_[0]->first_child( qq{$gi2\[text() $op $text]}))
  4786.                             };
  4787.                 }
  4788.               else
  4789.                 { $test = qq{ \$_[0]->first_child(qq{$gi2\[text() $op $text]}) } ; }
  4790.             }
  4791.           elsif( $cond=~ m{^\s*($REG_NAME_W)?\s*     # $1
  4792.                            \[\s*(?:text|string)\(\s* #   [string(
  4793.                            ($REG_NAME)\s*\)          #         $2)
  4794.                            \s*(=~|!~)\s*             #            =~ or !~ ($3)
  4795.                            ($REG_REGEXP)             #              /$4/
  4796.                            \s*\]\s*$}xo)             #                  ]
  4797.             { # gi[string(gi2)=~ /regexp/]
  4798.               my( $gi, $gi2, $match, $regexp)= ($1, $2, $3, $4);
  4799.               if( $gi && ($gi ne '*'))
  4800.                 { $test = qq{   (\$_[0]->gi eq "$gi") 
  4801.                              && ( \$_[0]->field( "$gi2") $match $regexp)
  4802.                             };
  4803.                 }
  4804.               else
  4805.                 { $test = qq{\$_[0]->field( "$gi2") $match $regexp}; }
  4806.             }
  4807.           else
  4808.             { croak "wrong condition '$original_cond'"; }
  4809.         }
  4810.  
  4811.       #warn "init: '$init' - test: '$test'\n";
  4812.  
  4813.       my $s= eval "sub { $init; return \$_[0] if( $not($test)) }";
  4814.       if( $@) 
  4815.         { croak "wrong navigation condition '$original_cond' ($@);" }
  4816.       return $s;
  4817.     }
  4818.  
  4819.   sub _op
  4820.     { my $op= shift;
  4821.       if(    $op eq '=')  { $op= 'eq'; }
  4822.       elsif( $op eq '!=') { $op= 'ne'; }
  4823.       return $op;
  4824.     }
  4825.  
  4826.   sub _att_err_empty_string
  4827.     { my( $var, $att)= @_;
  4828.       return qq{ my \$$var= \$_[0]->{'att'}->{"$att"}; unless( defined( \$$var)) { \$$var= ''; } }
  4829.     }
  4830.  
  4831.   sub passes
  4832.     { my( $elt, $cond)= @_;
  4833.       return $elt unless $cond;
  4834.       my $sub= ($cond_cache{$cond} ||= _install_cond( $cond));
  4835.       return $sub->( $elt);
  4836.     }
  4837. }
  4838. # end-extract twig_nodes
  4839.  
  4840. sub set_parent 
  4841.   { $_[0]->{parent}= $_[1];
  4842.     weaken( $_[0]->{parent}) if( $XML::Twig::weakrefs);
  4843.   }
  4844.  
  4845. #start-extract twig_node
  4846. sub parent
  4847.   { my $elt= shift;
  4848.     my $cond= shift || return $elt->{parent};
  4849.     do { $elt= $elt->{parent} || return; } until (!$elt || $elt->passes( $cond));
  4850.     return $elt;
  4851.   }
  4852. #end-extract twig_node
  4853.  
  4854. sub set_first_child 
  4855.   { delete $_[0]->{empty};
  4856.     $_[0]->{'first_child'}= $_[1]; 
  4857.   }
  4858.  
  4859. #start-extract twig_node
  4860. sub first_child
  4861.   { my $elt= shift;
  4862.     my $cond= shift || return $elt->{first_child};
  4863.     my $child= $elt->{first_child};
  4864.     my $test_cond= ($cond_cache{$cond} ||= _install_cond( $cond));
  4865.     while( $child && !$test_cond->( $child)) 
  4866.        { $child= $child->{next_sibling}; }
  4867.     return $child;
  4868.   }
  4869. #end-extract twig_node
  4870.   
  4871. sub _first_child   { return $_[0]->{first_child};  }
  4872. sub _last_child    { return $_[0]->{last_child};   }
  4873. sub _next_sibling  { return $_[0]->{next_sibling}; }
  4874. sub _prev_sibling  { return $_[0]->{prev_sibling}; }
  4875. sub _parent        { return $_[0]->{parent};       }
  4876. sub _next_siblings { my $elt= shift; my @siblings; while( $elt= $elt->{next_sibling}) { push @siblings, $elt; } return @siblings; }
  4877. sub _prev_siblings { my $elt= shift; my @siblings; while( $elt= $elt->{prev_sibling}) { push @siblings, $elt; } return @siblings; }
  4878.  
  4879. # sets a field
  4880. # arguments $record, $cond, @content
  4881. sub set_field
  4882.   { my $record = shift;
  4883.     my $cond = shift;
  4884.     my $child= $record->first_child( $cond);
  4885.     if( $child)
  4886.       { $child->set_content( @_); }
  4887.     else
  4888.       { if( $cond=~ m{^\s*($REG_NAME)})
  4889.           { my $gi= $1;
  4890.             $child= $record->insert_new_elt( last_child => $gi, @_); 
  4891.           }
  4892.         else
  4893.           { croak "can't create a field name from $cond"; }
  4894.       } 
  4895.     return $child;
  4896.   }
  4897.  
  4898. sub set_last_child 
  4899.   { delete $_[0]->{empty};
  4900.     $_[0]->{'last_child'}= $_[1];
  4901.     weaken( $_[0]->{'last_child'}) if( $XML::Twig::weakrefs);
  4902.   }
  4903.  
  4904. #start-extract twig_node
  4905. sub last_child
  4906.   { my $elt= shift;
  4907.     my $cond= shift || return $elt->{last_child};
  4908.     my $test_cond= ($cond_cache{$cond} ||= _install_cond( $cond));
  4909.     my $child= $elt->{last_child};
  4910.     while( $child && !$test_cond->( $child) )
  4911.       { $child= $child->{prev_sibling}; }
  4912.     return $child
  4913.   }
  4914. #end-extract twig_node
  4915.  
  4916.  
  4917. sub set_prev_sibling 
  4918.   { $_[0]->{'prev_sibling'}= $_[1]; 
  4919.     weaken( $_[0]->{'prev_sibling'}) if( $XML::Twig::weakrefs); 
  4920.   }
  4921.  
  4922. #start-extract twig_node
  4923. sub prev_sibling
  4924.   { my $elt= shift;
  4925.     my $cond= shift || return $elt->{prev_sibling};
  4926.     my $test_cond= ($cond_cache{$cond} ||= _install_cond( $cond));
  4927.     my $sibling= $elt->{prev_sibling};
  4928.     while( $sibling && !$test_cond->( $sibling) )
  4929.           { $sibling= $sibling->{prev_sibling}; }
  4930.     return $sibling;
  4931.   }
  4932. #end-extract twig_node
  4933.  
  4934. sub set_next_sibling { $_[0]->{'next_sibling'}= $_[1]; }
  4935.  
  4936. #start-extract twig_node
  4937. sub next_sibling
  4938.   { my $elt= shift;
  4939.     my $cond= shift || return $elt->{next_sibling};
  4940.     my $test_cond= ($cond_cache{$cond} ||= _install_cond( $cond));
  4941.     my $sibling= $elt->{next_sibling};
  4942.     while( $sibling && !$test_cond->( $sibling) )
  4943.           { $sibling= $sibling->{next_sibling}; }
  4944.     return $sibling;
  4945.   }
  4946.  
  4947. # methods dealing with the class attribute, convenient if you work with xhtml
  4948. sub class     { my( $elt)= @_; return $elt->{'att'}->{'class'}; }
  4949. sub set_class { my( $elt, $class)= @_; $elt->set_att( class => $class); }
  4950.  
  4951. # adds a class to an element
  4952. sub add_to_class
  4953.   { my( $elt, $new_class)= @_;
  4954.     return $elt unless $new_class;
  4955.     my $class= $elt->class;
  4956.     my %class= $class ? map { $_ => 1 } split /\s+/, $class : ();
  4957.     $class{$new_class}= 1;
  4958.     $elt->set_class( join( ' ', sort keys %class));
  4959.   }
  4960.  
  4961. sub att_to_class      { my( $elt, $att)= @_; $elt->set_class( $elt->{'att'}->{$att}); }
  4962. sub add_att_to_class  { my( $elt, $att)= @_; $elt->add_to_class( $elt->{'att'}->{$att}); }
  4963. sub move_att_to_class { my( $elt, $att)= @_; $elt->add_to_class( $elt->{'att'}->{$att});
  4964.                         $elt->del_att( $att); 
  4965.                       }
  4966. sub tag_to_class      { my( $elt)= @_; $elt->set_class( $elt->tag);    }
  4967. sub add_tag_to_class  { my( $elt)= @_; $elt->add_to_class( $elt->tag); }
  4968. sub set_tag_class     { my( $elt, $new_tag)= @_; $elt->add_tag_to_class; $elt->set_tag( $new_tag); }
  4969.  
  4970. sub in_class          
  4971.   { my( $elt, $class)= @_;
  4972.     my $elt_class= $elt->class;
  4973.     return unless( defined $elt_class);
  4974.     return $elt->class=~ m{(?:^|\s)\Q$class\E(?:\s|$)} ? $elt : 0;
  4975.   }
  4976.  
  4977.  
  4978. #end-extract twig_node
  4979.  
  4980. # get or set all attributes
  4981. # argument can be a hash or a hasref
  4982. sub set_atts 
  4983.   { my $elt= shift;
  4984.     my %atts;
  4985.     tie %atts, 'Tie::IxHash' if( keep_atts_order());
  4986.     %atts= ( isa( $_[0] || '', 'HASH')) ? %{$_[0]} : @_;
  4987.     $elt->{att}= \%atts;
  4988.     if( exists $atts{$ID}) { $elt->_set_id( $atts{$ID}); }
  4989.     return $elt;
  4990.   }
  4991.  
  4992. sub atts      { return $_[0]->{att};           }
  4993. sub att_names { return sort keys %{$_[0]->{att}};   }
  4994. sub del_atts  { $_[0]->{att}={}; return $_[0]; }
  4995.  
  4996. # get or set a single attribute (set works for several atts)
  4997. sub set_att 
  4998.   { my $elt= shift;
  4999.     
  5000.     unless( $elt->{att})
  5001.       { $elt->{att}={};
  5002.         tie %{$elt->{att}}, 'Tie::IxHash' if( keep_atts_order());
  5003.       }
  5004.  
  5005.     while(@_) 
  5006.       { my( $att, $val)= (shift, shift);
  5007.         $elt->{att}->{$att}= $val;
  5008.         if( $att eq $ID) { $elt->_set_id( $val); } 
  5009.       }
  5010.     return $elt;
  5011.   }
  5012.  
  5013. sub att { return $_[0]->{att}->{$_[1]}; }
  5014. sub del_att 
  5015.   { my $elt= shift;
  5016.     while( @_) { delete $elt->{'att'}->{shift()}; }
  5017.     return $elt;
  5018.   }
  5019.  
  5020. # delete an attribute from all descendants of an element
  5021. sub strip_att
  5022.   { my( $elt, $att)= @_;
  5023.     $_->del_att( $att) foreach ($elt->descendants_or_self( qq{*[\@$att]}));
  5024.     return $elt;
  5025.   }
  5026.  
  5027. sub change_att_name
  5028.   { my( $elt, $old_name, $new_name)= @_;
  5029.     my $value= $elt->{'att'}->{$old_name};
  5030.     return $elt unless( defined $value);
  5031.     $elt->del_att( $old_name)
  5032.         ->set_att( $new_name => $value);
  5033.     return $elt;
  5034.   }
  5035.  
  5036. sub set_twig_current { $_[0]->{twig_current}=1; }
  5037. sub del_twig_current { delete $_[0]->{twig_current}; }
  5038.  
  5039.  
  5040. # get or set the id attribute
  5041. sub set_id 
  5042.   { my( $elt, $id)= @_;
  5043.     $elt->del_id() if( exists $elt->{att}->{$ID});
  5044.     $elt->set_att($ID, $id); 
  5045.     $elt->_set_id( $id);
  5046.     return $elt;
  5047.   }
  5048.  
  5049. # only set id, does not update the attribute value
  5050. sub _set_id
  5051.   { my( $elt, $id)= @_;
  5052.     my $t= $elt->twig || $elt;
  5053.     $t->{twig_id_list}->{$id}= $elt;
  5054.     weaken(  $t->{twig_id_list}->{$id}) if( $XML::Twig::weakrefs);
  5055.     return $elt;
  5056.   }
  5057.  
  5058. sub id { return $_[0]->{att}->{$ID}; }
  5059.  
  5060. # methods used to add ids to elements that don't have one
  5061. BEGIN 
  5062. { my $id_nb   = "0001";
  5063.   my $id_seed = "twig_id_";
  5064.  
  5065.   sub set_id_seed
  5066.     { $id_seed= $_[1]; $id_nb=1; }
  5067.  
  5068.   sub add_id
  5069.     { my $elt= shift;
  5070.       $elt->set_id( $id_seed . $id_nb++) unless( $elt->{'att'}->{$ID});
  5071.     }
  5072.  
  5073. }
  5074.  
  5075.  
  5076.  
  5077. # delete the id attribute and remove the element from the id list
  5078. sub del_id 
  5079.   { my $elt= shift;
  5080.     unless( exists $elt->{'att'}) { return $elt }; 
  5081.     unless( exists $elt->{'att'}->{$ID}) { return $elt }; 
  5082.     my $id= $elt->{'att'}->{$ID};
  5083.  
  5084.     delete $elt->{'att'}->{$ID}; 
  5085.  
  5086.     my $t= shift || $elt->twig;
  5087.     unless( $t) { return $elt; }
  5088.     if( exists $t->{twig_id_list}->{$id}) { delete $t->{twig_id_list}->{$id}; }
  5089.  
  5090.     return $elt;
  5091.   }
  5092.  
  5093. # return the list of children
  5094. #start-extract twig_node
  5095. sub children
  5096.   { my $elt= shift;
  5097.     my @children;
  5098.     my $child= $elt->first_child( @_);
  5099.     while( $child) 
  5100.       { push @children, $child;
  5101.         $child= $child->next_sibling( @_);
  5102.       } 
  5103.     return @children;
  5104.   }
  5105.  
  5106. sub _children
  5107.   { my $elt= shift;
  5108.     my @children=();
  5109.     my $child= $elt->_first_child();
  5110.     while( $child) 
  5111.       { push @children, $child;
  5112.         $child= $child->{next_sibling};
  5113.       } 
  5114.     return @children;
  5115.   }
  5116.  
  5117. sub children_copy
  5118.   { my $elt= shift;
  5119.     my @children;
  5120.     my $child= $elt->first_child( @_);
  5121.     while( $child) 
  5122.       { push @children, $child->copy;
  5123.         $child= $child->next_sibling( @_);
  5124.       } 
  5125.     return @children;
  5126.   }
  5127.  
  5128.  
  5129. sub children_count
  5130.   { my $elt= shift;
  5131.     my $cond= shift;
  5132.     my $count=0;
  5133.     my $child= $elt->{first_child};
  5134.     while( $child)
  5135.       { $count++ if( $child->passes( $cond)); 
  5136.         $child= $child->{next_sibling};
  5137.       }
  5138.     return $count;
  5139.   }
  5140.  
  5141. sub children_text
  5142.   { my $elt= shift;
  5143.     return wantarray() ? map { $_->text} $elt->children( @_)
  5144.                        : join( '', map { $_->text} $elt->children( @_) )
  5145.                        ;
  5146.   }
  5147.  
  5148. sub children_trimmed_text
  5149.   { my $elt= shift;
  5150.     return wantarray() ? map { $_->trimmed_text} $elt->children( @_)
  5151.                        : join( '', map { $_->trimmed_text} $elt->children( @_) )
  5152.                        ;
  5153.   }
  5154.  
  5155. sub all_children_are
  5156.   { my( $parent, $cond)= @_;
  5157.     foreach my $child ($parent->children)
  5158.       { return 0 unless( $child->passes( $cond)); }
  5159.     return 1;
  5160.   }
  5161.  
  5162.  
  5163. sub ancestors
  5164.   { my( $elt, $cond)= @_;
  5165.     my @ancestors;
  5166.     while( $elt->{parent})
  5167.       { $elt= $elt->{parent};
  5168.         push @ancestors, $elt if( $elt->passes( $cond));
  5169.       }
  5170.     return @ancestors;
  5171.   }
  5172.  
  5173. sub ancestors_or_self
  5174.   { my( $elt, $cond)= @_;
  5175.     my @ancestors;
  5176.     while( $elt)
  5177.       { push @ancestors, $elt if( $elt->passes( $cond));
  5178.         $elt= $elt->{parent};
  5179.       }
  5180.     return @ancestors;
  5181.   }
  5182.  
  5183.  
  5184. sub _ancestors
  5185.   { my( $elt, $include_self)= @_;
  5186.     my @ancestors= $include_self ? ($elt) : ();
  5187.     while( $elt= $elt->{parent}) { push @ancestors, $elt; }
  5188.     return @ancestors;
  5189.   }
  5190.  
  5191.  
  5192. sub inherit_att
  5193.   { my $elt= shift;
  5194.     my $att= shift;
  5195.     my %tags= map { ($_, 1) } @_;
  5196.  
  5197.     do 
  5198.       { if(   (defined $elt->{'att'}->{$att})
  5199.            && ( !%tags || $tags{$XML::Twig::index2gi[$elt->{'gi'}]})
  5200.           )
  5201.           { return $elt->{'att'}->{$att}; }
  5202.       } while( $elt= $elt->{parent});
  5203.     return undef;
  5204.   }
  5205.  
  5206.  
  5207. sub current_ns_prefixes
  5208.   { my $elt= shift;
  5209.     my %prefix;
  5210.     $prefix{''}=1 if( $elt->namespace( ''));
  5211.     while( $elt)
  5212.       { my @ns= grep { !m{^xml} } map { m{^([^:]+):} } ($XML::Twig::index2gi[$elt->{'gi'}], $elt->att_names);
  5213.         $prefix{$_}=1 foreach (@ns);
  5214.         $elt= $elt->{parent};
  5215.       }
  5216.  
  5217.     return sort keys %prefix;
  5218.   }
  5219.  
  5220. # kinda counter-intuitive actually:
  5221. # the next element is found by looking for the next open tag after from the
  5222. # current one, which is the first child, if it exists, or the next sibling
  5223. # or the first next sibling of an ancestor
  5224. # optional arguments are: 
  5225. #   - $subtree_root: a reference to an element, when the next element is not 
  5226. #                    within $subtree_root anymore then next_elt returns undef
  5227. #   - $cond: a condition, next_elt returns the next element matching the condition
  5228.                  
  5229. sub next_elt
  5230.   { my $elt= shift;
  5231.     my $subtree_root= 0;
  5232.     $subtree_root= shift if( defined $_[0] and (isa( $_[0], 'XML::Twig::Elt')));
  5233.     my $cond= shift;
  5234.     my $next_elt;
  5235.  
  5236.     my $ind;                                                              # optimization
  5237.     my $test_cond;
  5238.     if( $cond)                                                            # optimization
  5239.       { unless( defined( $ind= $XML::Twig::gi2index{$cond}) )             # optimization
  5240.           { $test_cond= ($cond_cache{$cond} ||= _install_cond( $cond)); } # optimization
  5241.       }                                                                   # optimization
  5242.     
  5243.     do
  5244.       { if( $next_elt= $elt->{first_child})
  5245.           { # simplest case: the elt has a child
  5246.           }
  5247.          elsif( $next_elt= $elt->{next_sibling}) 
  5248.           { # no child but a next sibling (just check we stay within the subtree)
  5249.           
  5250.             # case where elt is subtree_root, is empty and has a sibling
  5251.             return undef if( $subtree_root && ($elt == $subtree_root));
  5252.             
  5253.           }
  5254.         else
  5255.           { # case where the element has no child and no next sibling:
  5256.             # get the first next sibling of an ancestor, checking subtree_root 
  5257.           
  5258.             # case where elt is subtree_root, is empty and has no sibling
  5259.             return undef if( $subtree_root && ($elt == $subtree_root));
  5260.              
  5261.             $next_elt= $elt->{parent};
  5262.  
  5263.             until( $next_elt->{next_sibling})
  5264.               { return undef if( $subtree_root && ($subtree_root == $next_elt));
  5265.                 $next_elt= $next_elt->{parent} || return undef;
  5266.               }
  5267.             return undef if( $subtree_root && ($subtree_root == $next_elt)); 
  5268.             $next_elt= $next_elt->{next_sibling};   
  5269.           }  
  5270.       $elt= $next_elt;                   # just in case we need to loop
  5271.     } until(    ! defined $elt 
  5272.              || ! defined $cond 
  5273.          || (defined $ind       && ($elt->{gi} eq $ind))   # optimization
  5274.          || (defined $test_cond && ($test_cond->( $elt)))
  5275.                );
  5276.     
  5277.       return $elt;
  5278.       }
  5279.  
  5280. # return the next_elt within the element
  5281. # just call next_elt with the element as first and second argument
  5282. sub first_descendant { return $_[0]->next_elt( @_); }
  5283.  
  5284. # get the last descendant, # then return the element found or call prev_elt with the condition
  5285. sub last_descendant
  5286.   { my( $elt, $cond)= @_;
  5287.     my $last_descendant= $elt->_last_descendant;
  5288.     if( !$cond || $last_descendant->matches( $cond))
  5289.       { return $last_descendant; }
  5290.     else
  5291.       { return $last_descendant->prev_elt( $elt, $cond); }
  5292.   }
  5293.  
  5294. # no argument allowed here, just go down the last_child recursively
  5295. sub _last_descendant
  5296.   { my $elt= shift;
  5297.     while( my $child= $elt->{last_child}) { $elt= $child; }
  5298.     return $elt;
  5299.   }
  5300.  
  5301. # counter-intuitive too:
  5302. # the previous element is found by looking
  5303. # for the first open tag backwards from the current one
  5304. # it's the last descendant of the previous sibling 
  5305. # if it exists, otherwise it's simply the parent
  5306. sub prev_elt
  5307.   { my $elt= shift;
  5308.     my $subtree_root= 0;
  5309.     if( defined $_[0] and (isa( $_[0], 'XML::Twig::Elt')))
  5310.       { $subtree_root= shift ;
  5311.         return undef if( $elt == $subtree_root);
  5312.       }
  5313.     my $cond= shift;
  5314.     # get prev elt
  5315.     my $prev_elt;
  5316.     do
  5317.       { return undef if( $elt == $subtree_root);
  5318.         if( $prev_elt= $elt->{prev_sibling})
  5319.           { while( $prev_elt->{last_child})
  5320.               { $prev_elt= $prev_elt->{last_child}; }
  5321.           }
  5322.         else
  5323.           { $prev_elt= $elt->{parent} || return undef; }
  5324.         $elt= $prev_elt;     # in case we need to loop 
  5325.       } until( $elt->passes( $cond));
  5326.  
  5327.     return $elt;
  5328.   }
  5329.  
  5330. sub _following_elt
  5331.   { my( $elt)= @_;
  5332.     while( $elt && !$elt->{next_sibling})
  5333.       { $elt= $elt->{parent}; }
  5334.     return $elt ? $elt->{next_sibling} : undef;
  5335.   }
  5336.  
  5337. sub following_elt
  5338.   { my( $elt, $cond)= @_;
  5339.     $elt= $elt->_following_elt || return undef;
  5340.     return $elt if( !$cond || $elt->matches( $cond));
  5341.     return $elt->next_elt( $cond);
  5342.   }
  5343.  
  5344. sub following_elts
  5345.   { my( $elt, $cond)= @_;
  5346.     if( !$cond) { $cond= undef; }
  5347.     my $following= $elt->following_elt( $cond);
  5348.     if( $following)
  5349.       { my @followings= $following;
  5350.         while( $following= $following->next_elt( $cond))
  5351.           { push @followings, $following; }
  5352.         return( @followings);
  5353.       }
  5354.     else
  5355.       { return (); }
  5356.   }
  5357.  
  5358. sub _preceding_elt
  5359.   { my( $elt)= @_;
  5360.     while( $elt && !$elt->{prev_sibling})
  5361.       { $elt= $elt->{parent}; }
  5362.     return $elt ? $elt->{prev_sibling}->last_descendant : undef;
  5363.   }
  5364.  
  5365. sub preceding_elt
  5366.   { my( $elt, $cond)= @_;
  5367.     $elt= $elt->_preceding_elt || return undef;
  5368.     return $elt if( !$cond || $elt->matches( $cond));
  5369.     return $elt->prev_elt( $cond);
  5370.   }
  5371.  
  5372. sub preceding_elts
  5373.   { my( $elt, $cond)= @_;
  5374.     if( !$cond) { $cond= undef; }
  5375.     my $preceding= $elt->preceding_elt( $cond);
  5376.     if( $preceding)
  5377.       { my @precedings= $preceding;
  5378.         while( $preceding= $preceding->prev_elt( $cond))
  5379.           { push @precedings, $preceding; }
  5380.         return( @precedings);
  5381.       }
  5382.     else
  5383.       { return (); }
  5384.   }
  5385.  
  5386. # used in get_xpath
  5387. sub _self
  5388.   { my( $elt, $cond)= @_;
  5389.     return $cond ? $elt->matches( $cond) : $elt;
  5390.   }
  5391.  
  5392. sub next_n_elt
  5393.   { my $elt= shift;
  5394.     my $offset= shift || return undef;
  5395.     foreach (1..$offset)
  5396.       { $elt= $elt->next_elt( @_) || return undef; }
  5397.     return $elt;
  5398.   }
  5399.  
  5400. # checks whether $elt is included in $ancestor, returns 1 in that case
  5401. sub in
  5402.   { my ($elt, $ancestor)= @_;
  5403.     if( isa( $ancestor, 'XML::Twig::Elt'))
  5404.       { # element
  5405.         while( $elt= $elt->{parent}) { return $elt if( $elt ==  $ancestor); } 
  5406.       }
  5407.     else
  5408.       { # condition
  5409.         while( $elt= $elt->{parent}) { return $elt if( $elt->matches( $ancestor)); } 
  5410.       }
  5411.     return 0;           
  5412.   }
  5413.  
  5414. sub first_child_text  
  5415.   { my $elt= shift;
  5416.     my $dest=$elt->first_child(@_) or return '';
  5417.     return $dest->text;
  5418.   }
  5419.   
  5420. sub first_child_trimmed_text  
  5421.   { my $elt= shift;
  5422.     my $dest=$elt->first_child(@_) or return '';
  5423.     return $dest->trimmed_text;
  5424.   }
  5425.   
  5426. sub first_child_matches
  5427.   { my $elt= shift;
  5428.     my $dest= $elt->{first_child} or return undef;
  5429.     return $dest->passes( @_);
  5430.   }
  5431.   
  5432. sub last_child_text  
  5433.   { my $elt= shift;
  5434.     my $dest=$elt->last_child(@_) or return '';
  5435.     return $dest->text;
  5436.   }
  5437.   
  5438. sub last_child_trimmed_text  
  5439.   { my $elt= shift;
  5440.     my $dest=$elt->last_child(@_) or return '';
  5441.     return $dest->trimmed_text;
  5442.   }
  5443.   
  5444. sub last_child_matches
  5445.   { my $elt= shift;
  5446.     my $dest= $elt->{last_child} or return undef;
  5447.     return $dest->passes( @_);
  5448.   }
  5449.   
  5450. sub child_text
  5451.   { my $elt= shift;
  5452.     my $dest=$elt->child(@_) or return '';
  5453.     return $dest->text;
  5454.   }
  5455.   
  5456. sub child_trimmed_text
  5457.   { my $elt= shift;
  5458.     my $dest=$elt->child(@_) or return '';
  5459.     return $dest->trimmed_text;
  5460.   }
  5461.   
  5462. sub child_matches
  5463.   { my $elt= shift;
  5464.     my $nb= shift;
  5465.     my $dest= $elt->child( $nb) or return undef;
  5466.     return $dest->passes( @_);
  5467.   }
  5468.  
  5469. sub prev_sibling_text  
  5470.   { my $elt= shift;
  5471.     my $dest=$elt->prev_sibling(@_) or return '';
  5472.     return $dest->text;
  5473.   }
  5474.   
  5475. sub prev_sibling_trimmed_text  
  5476.   { my $elt= shift;
  5477.     my $dest=$elt->prev_sibling(@_) or return '';
  5478.     return $dest->trimmed_text;
  5479.   }
  5480.   
  5481. sub prev_sibling_matches
  5482.   { my $elt= shift;
  5483.     my $dest= $elt->{prev_sibling} or return undef;
  5484.     return $dest->passes( @_);
  5485.   }
  5486.   
  5487. sub next_sibling_text  
  5488.   { my $elt= shift;
  5489.     my $dest=$elt->next_sibling(@_) or return '';
  5490.     return $dest->text;
  5491.   }
  5492.   
  5493. sub next_sibling_trimmed_text  
  5494.   { my $elt= shift;
  5495.     my $dest=$elt->next_sibling(@_) or return '';
  5496.     return $dest->trimmed_text;
  5497.   }
  5498.   
  5499. sub next_sibling_matches
  5500.   { my $elt= shift;
  5501.     my $dest= $elt->{next_sibling} or return undef;
  5502.     return $dest->passes( @_);
  5503.   }
  5504.   
  5505. sub prev_elt_text  
  5506.   { my $elt= shift;
  5507.     my $dest=$elt->prev_elt(@_) or return '';
  5508.     return $dest->text;
  5509.   }
  5510.   
  5511. sub prev_elt_trimmed_text  
  5512.   { my $elt= shift;
  5513.     my $dest=$elt->prev_elt(@_) or return '';
  5514.     return $dest->trimmed_text;
  5515.   }
  5516.   
  5517. sub prev_elt_matches
  5518.   { my $elt= shift;
  5519.     my $dest= $elt->prev_elt or return undef;
  5520.     return $dest->passes( @_);
  5521.   }
  5522.   
  5523. sub next_elt_text  
  5524.   { my $elt= shift;
  5525.     my $dest=$elt->next_elt(@_) or return '';
  5526.     return $dest->text;
  5527.   }
  5528.   
  5529. sub next_elt_trimmed_text  
  5530.   { my $elt= shift;
  5531.     my $dest=$elt->next_elt(@_) or return '';
  5532.     return $dest->trimmed_text;
  5533.   }
  5534.   
  5535. sub next_elt_matches
  5536.   { my $elt= shift;
  5537.     my $dest= $elt->next_elt or return undef;
  5538.     return $dest->passes( @_);
  5539.   }
  5540.   
  5541. sub parent_text  
  5542.   { my $elt= shift;
  5543.     my $dest=$elt->parent(@_) or return '';
  5544.     return $dest->text;
  5545.   }
  5546.   
  5547. sub parent_trimmed_text  
  5548.   { my $elt= shift;
  5549.     my $dest=$elt->parent(@_) or return '';
  5550.     return $dest->trimmed_text;
  5551.   }
  5552.   
  5553. sub parent_matches
  5554.   { my $elt= shift;
  5555.     my $dest= $elt->{parent} or return undef;
  5556.     return $dest->passes( @_);
  5557.   }
  5558.  
  5559. sub is_first_child
  5560.   { my $elt= shift;
  5561.     my $parent= $elt->{parent} or return 0;
  5562.     my $first_child= $parent->first_child( @_) or return 0;
  5563.     return ($first_child == $elt) ? $elt : 0;
  5564.   }
  5565.  
  5566. sub is_last_child
  5567.   { my $elt= shift;
  5568.     my $parent= $elt->{parent} or return 0;
  5569.     my $last_child= $parent->last_child( @_) or return 0;
  5570.     return ($last_child == $elt) ? $elt : 0;
  5571.   }
  5572.  
  5573. # returns the depth level of the element
  5574. # if 2 parameter are used then counts the 2cd element name in the
  5575. # ancestors list
  5576. sub level
  5577.   { my( $elt, $cond)= @_;
  5578.    
  5579.     my $level=0;
  5580.     my $name=shift || '';
  5581.     while( $elt= $elt->{parent}) { $level++ if( !$cond || $elt->matches( $cond)); }
  5582.     return $level;           
  5583.   }
  5584.  
  5585. # checks whether $elt has an ancestor that satisfies $cond, returns the ancestor
  5586. sub in_context
  5587.   { my ($elt, $cond, $level)= @_;
  5588.     $level= -1 unless( $level) ;  # $level-- will never hit 0
  5589.  
  5590.     while( $level)
  5591.       { $elt= $elt->{parent} or return 0;
  5592.         if( $elt->matches( $cond)) { return $elt; }
  5593.         $level--;
  5594.       }
  5595.     return 0;
  5596.   }
  5597.  
  5598. sub _descendants
  5599.   { my( $subtree_root, $include_self)= @_;
  5600.     my @descendants= $include_self ? ($subtree_root) : ();
  5601.  
  5602.     my $elt= $subtree_root; 
  5603.     my $next_elt;   
  5604.  
  5605.     MAIN: while( 1)  
  5606.       { if( $next_elt= $elt->{first_child})
  5607.           { # simplest case: the elt has a child
  5608.           }
  5609.         elsif( $next_elt= $elt->{next_sibling}) 
  5610.           { # no child but a next sibling (just check we stay within the subtree)
  5611.           
  5612.             # case where elt is subtree_root, is empty and has a sibling
  5613.             last MAIN if( $elt == $subtree_root);
  5614.           }
  5615.         else
  5616.           { # case where the element has no child and no next sibling:
  5617.             # get the first next sibling of an ancestor, checking subtree_root 
  5618.                 
  5619.             # case where elt is subtree_root, is empty and has no sibling
  5620.             last MAIN if( $elt == $subtree_root);
  5621.                
  5622.             # backtrack until we find a parent with a next sibling
  5623.             $next_elt= $elt->{parent} || last;
  5624.             until( $next_elt->{next_sibling})
  5625.               { last MAIN if( $subtree_root == $next_elt);
  5626.                 $next_elt= $next_elt->{parent} || last MAIN;
  5627.               }
  5628.             last MAIN if( $subtree_root == $next_elt); 
  5629.             $next_elt= $next_elt->{next_sibling};   
  5630.           }  
  5631.         $elt= $next_elt || last MAIN;
  5632.         push @descendants, $elt;
  5633.       }
  5634.     return @descendants;
  5635.   }
  5636.  
  5637.  
  5638. sub descendants
  5639.   { my( $subtree_root, $cond)= @_;
  5640.     my @descendants=(); 
  5641.     my $elt= $subtree_root;
  5642.     
  5643.     # this branch is pure optimisation for speed: if $cond is a gi replace it
  5644.     # by the index of the gi and loop here 
  5645.     # start optimization
  5646.     my $ind;
  5647.     if( !$cond || ( defined ( $ind= $XML::Twig::gi2index{$cond})) )
  5648.       {
  5649.         my $next_elt;
  5650.  
  5651.         while( 1)  
  5652.           { if( $next_elt= $elt->{first_child})
  5653.                 { # simplest case: the elt has a child
  5654.                 }
  5655.              elsif( $next_elt= $elt->{next_sibling}) 
  5656.               { # no child but a next sibling (just check we stay within the subtree)
  5657.            
  5658.                 # case where elt is subtree_root, is empty and has a sibling
  5659.                 last if( $subtree_root && ($elt == $subtree_root));
  5660.               }
  5661.             else
  5662.               { # case where the element has no child and no next sibling:
  5663.                 # get the first next sibling of an ancestor, checking subtree_root 
  5664.                 
  5665.                 # case where elt is subtree_root, is empty and has no sibling
  5666.                 last if( $subtree_root && ($elt == $subtree_root));
  5667.                
  5668.                 # backtrack until we find a parent with a next sibling
  5669.                 $next_elt= $elt->{parent} || last undef;
  5670.                 until( $next_elt->{next_sibling})
  5671.                   { last if( $subtree_root && ($subtree_root == $next_elt));
  5672.                     $next_elt= $next_elt->{parent} || last;
  5673.                   }
  5674.                 last if( $subtree_root && ($subtree_root == $next_elt)); 
  5675.                 $next_elt= $next_elt->{next_sibling};   
  5676.               }  
  5677.             $elt= $next_elt || last;
  5678.             push @descendants, $elt if( !$cond || ($elt->{gi} eq $ind));
  5679.           }
  5680.       }
  5681.     else
  5682.     # end optimization
  5683.       { # branch for a complex condition: use the regular (slow but simple) way
  5684.         while( $elt= $elt->next_elt( $subtree_root, $cond))
  5685.           { push @descendants, $elt; }
  5686.       }
  5687.     return @descendants;
  5688.   }
  5689.  
  5690.  
  5691. sub descendants_or_self
  5692.   { my( $elt, $cond)= @_;
  5693.     my @descendants= $elt->passes( $cond) ? ($elt) : (); 
  5694.     push @descendants, $elt->descendants( $cond);
  5695.     return @descendants;
  5696.   }
  5697.   
  5698. sub sibling
  5699.   { my $elt= shift;
  5700.     my $nb= shift;
  5701.     if( $nb > 0)
  5702.       { foreach( 1..$nb)
  5703.           { $elt= $elt->next_sibling( @_) or return undef; }
  5704.       }
  5705.     elsif( $nb < 0)
  5706.       { foreach( 1..(-$nb))
  5707.           { $elt= $elt->prev_sibling( @_) or return undef; }
  5708.       }
  5709.     else # $nb == 0
  5710.       { return $elt->passes( $_[0]); }
  5711.     return $elt;
  5712.   }
  5713.  
  5714. sub sibling_text
  5715.   { my $elt= sibling( @_);
  5716.     return $elt ? $elt->text : undef;
  5717.   }
  5718.  
  5719.  
  5720. sub child
  5721.   { my $elt= shift;
  5722.     my $nb= shift;
  5723.     if( $nb >= 0)
  5724.       { $elt= $elt->first_child( @_) or return undef;
  5725.         foreach( 1..$nb)
  5726.           { $elt= $elt->next_sibling( @_) or return undef; }
  5727.       }
  5728.     else
  5729.       { $elt= $elt->last_child( @_) or return undef;
  5730.         foreach( 2..(-$nb))
  5731.           { $elt= $elt->prev_sibling( @_) or return undef; }
  5732.       }
  5733.     return $elt;
  5734.   }
  5735.  
  5736. sub prev_siblings
  5737.   { my $elt= shift;
  5738.     my @siblings=();
  5739.     while( $elt= $elt->prev_sibling( @_))
  5740.       { unshift @siblings, $elt; }
  5741.     return @siblings;
  5742.   }
  5743.  
  5744. sub pos
  5745.   { my $elt= shift;
  5746.     return 0 if ($_[0] && !$elt->matches( @_));
  5747.     my $pos=1;
  5748.     $pos++ while( $elt= $elt->prev_sibling( @_));
  5749.     return $pos;
  5750.   }
  5751.  
  5752.  
  5753. sub next_siblings
  5754.   { my $elt= shift;
  5755.     my @siblings=();
  5756.     while( $elt= $elt->next_sibling( @_))
  5757.       { push @siblings, $elt; }
  5758.     return @siblings;
  5759.   }
  5760.  
  5761.  
  5762. # used by get_xpath: parses the xpath expression and generates a sub that performs the
  5763. # search
  5764. { my %axis2method;
  5765.   BEGIN { %axis2method= ( child               => 'children',
  5766.                           descendant          => 'descendants',
  5767.                          'descendant-or-self' => 'descendants_or_self',
  5768.                           parent              => 'parent_is',
  5769.                           ancestor            => 'ancestors',
  5770.                          'ancestor-or-self'   => 'ancestors_or_self',
  5771.                          'following-sibling'  => 'next_siblings',
  5772.                          'preceding-sibling'  => 'prev_siblings',
  5773.                           following           => 'following_elts',
  5774.                           preceding           => 'preceding_elts',
  5775.                           self                => '_self',
  5776.                         );
  5777.         }
  5778.  
  5779.   sub _install_xpath
  5780.     { my( $xpath_exp, $type)= @_;
  5781.       my $original_exp= $xpath_exp;
  5782.       my $sub= 'my $elt= shift; my @results;';
  5783.       
  5784.       # grab the root if expression starts with a /
  5785.       if( $xpath_exp=~ s{^/}{})
  5786.         { $sub .= '@results= ($elt->twig);'; }
  5787.       elsif( $xpath_exp=~ s{^\./}{})
  5788.         { $sub .= '@results= ($elt);'; }
  5789.       else
  5790.         { $sub .= '@results= ($elt);'; }
  5791.   
  5792.  
  5793.      #warn "xpath_exp= '$xpath_exp'\n";
  5794.       while( $xpath_exp &&
  5795.              $xpath_exp=~s{^\s*(/?)                            
  5796.                             # the xxx=~/regexp/ is a pain as it includes /  
  5797.                             (\s*(?:(?:($REG_AXIS)::)?(\*|$REG_NAME|\.\.|\.)\s*)?($REG_PREDICATE*)
  5798.                             )
  5799.                             (/|$)}{}xo)
  5800.   
  5801.         { my( $wildcard, $sub_exp, $axis, $gi, $predicates)= ($1, $2, $3, $4, $5);
  5802.           #warn "wildcard= '$wildcard', sub_exp= '$sub_exp', axis= '$axis', gi= '$gi', predicates= '$predicates'\n";
  5803.           
  5804.           # grab a parent
  5805.           if( $sub_exp eq '..')
  5806.             { croak "error in xpath expression $original_exp" if( $wildcard);
  5807.               $sub .= '@results= map { $_->{parent}} @results;';
  5808.             }
  5809.           # test the element itself
  5810.           elsif( $sub_exp=~ m{^\.(.*)$}s)
  5811.             { $sub .= "\@results= grep { \$_->matches( q{$1}) } \@results;" }
  5812.               # grab children
  5813.           else       
  5814.             { 
  5815.               if( !$axis)             
  5816.                 { $axis= $wildcard ? 'descendant' : 'child'; }
  5817.               if( !$gi or $gi eq '*') { $gi=''; }
  5818.               my $function;
  5819.   
  5820.               # "special" predicates, that return just one element
  5821.               if( $predicates && ($predicates =~ m{^\s*\[\s*((-\s*)?\d+)\s*\]\s*$}))
  5822.                 { my $offset= $1;
  5823.                   $offset-- if( $offset > 0);
  5824.                   $function=  $axis eq 'descendant' ? "next_n_elt( $offset, '$gi')" 
  5825.                            :  $axis eq 'child'      ? "child( $offset, '$gi')"
  5826.                            :                          croak "error [$1] not supported along axis '$axis'"
  5827.                            ;
  5828.                   $sub .= "\@results= grep { \$_ } map { \$_->$function } \@results;"
  5829.                 }
  5830.               elsif( $predicates && ($predicates =~ m{^\s*\[\s*last\s*\(\s*\)\s*\]\s*$}) )
  5831.                 { croak "error in xpath expression $original_exp, usage of // and last() not supported" if( $wildcard);
  5832.                    $sub .= "\@results= map { \$_->last_child( '$gi') } \@results;";
  5833.                 }
  5834.               else
  5835.                 { # follow the axis
  5836.                   #warn "axis: '$axis' - method: '$axis2method{$axis}' - gi: '$gi'\n";
  5837.  
  5838.                   my $follow_axis= " \$_->$axis2method{$axis}( '$gi')";
  5839.                   my $step= $follow_axis;
  5840.                   
  5841.                   # now filter using the predicate
  5842.                   while( $predicates=~ s{^\s*($REG_PREDICATE)\s*}{}o)
  5843.                     { my $pred= $1;
  5844.                       $pred=~ s{^\s*\[\s*}{};
  5845.                       $pred=~ s{\s*\]\s*$}{};
  5846.                       my $test="";
  5847.                       my $pos;
  5848.                       if( $pred=~ m{^(-?\s*\d+)$})
  5849.                         { my $pos= $1;
  5850.                           if( $step=~ m{^\s*grep(.*) (\$_->\w+\(\s*'[^']*'\s*\))})
  5851.                             { $step= "XML::Twig::_first_n $1 $pos, $2"; }
  5852.                           else
  5853.                             { if( $pos > 0) { $pos--; }
  5854.                               $step= "($step)[$pos]"; 
  5855.                             }
  5856.                           #warn "number predicate '$pos' - generated step '$step'\n";
  5857.                         }
  5858.                       else
  5859.                         { my $syntax_error=0;
  5860.                           do
  5861.                             { if( $pred =~ s{^string\(\s*\)\s*=\s*($REG_STRING)\s*}{}o)  # string()="string" pred
  5862.                                 { $test .= "\$_->text eq $1"; }
  5863.                              elsif( $pred =~ s{^string\(\s*\)\s*($REG_MATCH)\s*($REG_REGEXP)\s*}{}o)  # string()=~/regex/ pred
  5864.                                 { my( $match, $regexp)= ($1, $2);
  5865.                                   $test .= "\$_->text $match $regexp"; 
  5866.                                 }
  5867.                              elsif( $pred=~ s{^@($REG_NAME)\s*($REG_OP)\s*($REG_STRING|$REG_NUMBER)}{}o)  # @att="val" pred
  5868.                                 { my( $att, $oper, $val)= ($1, _op( $2), $3);
  5869.                                   $test .= qq{((defined \$_->{'att'}->{"$att"})  && (\$_->{'att'}->{"$att"} $oper $val))};
  5870.                                 }
  5871.                              elsif( $pred =~ s{^@($REG_NAME)\s*($REG_MATCH)\s*($REG_REGEXP)\s*}{}o)  # @att=~/regex/ pred XXX
  5872.                                 { my( $att, $match, $regexp)= ($1, $2, $3);
  5873.                                   $test .= qq{((defined \$_->{'att'}->{"$att"})  && (\$_->{'att'}->{"$att"} $match $regexp))};; 
  5874.                                 }
  5875.                              elsif( $pred=~ s{^@($REG_NAME)\s*}{}o)                      # @att pred
  5876.                                 { $test .= qq{(defined \$_->{'att'}->{"$1"})}; }
  5877.                              elsif( $pred=~ s{^\s*(?:not|!)\s*@($REG_NAME)\s*}{}o)       # not @att pred
  5878.                                 { $test .= qq{((\$_->is_elt) && (not defined \$_->{'att'}->{"$1"}))}; }
  5879.                               elsif( $pred=~ s{^\s*([()])}{})                            # ( or ) (just add to the test)
  5880.                                 { $test .= qq{$1};           }
  5881.                               elsif( $pred=~ s{^\s*(and|or)\s*}{})
  5882.                                 { $test .= lc " $1 "; }
  5883.                               else
  5884.                                 { $syntax_error=1; }
  5885.                              
  5886.                              } while( !$syntax_error && $pred);
  5887.                            croak "error in xpath expression $original_exp at $pred" if( $pred);
  5888.                            $step= " grep { $test } $step ";
  5889.                         }
  5890.                     }
  5891.                   #warn "step: '$step'";
  5892.                   $sub .= "\@results= grep { \$_ } map { $step } \@results;"; 
  5893.                 }
  5894.             }
  5895.         }
  5896.   
  5897.       if( $xpath_exp)
  5898.         { 
  5899.           croak "error in xpath expression $original_exp around $xpath_exp ";
  5900.         }
  5901.         
  5902.       $sub .= q{return XML::Twig::_unique_elts( @results); };
  5903.       #warn "generated: '$sub'\n";
  5904.       my $s= eval "sub { $sub }";
  5905.       if( $@) { croak "error in xpath expression $original_exp ($@);" }
  5906.       return( $s); 
  5907.     }
  5908. }
  5909.  
  5910.  
  5911.           
  5912. { # extremely elaborate caching mechanism
  5913.   my %xpath; # xpath_expression => subroutine_code;  
  5914.   sub get_xpath
  5915.     { my( $elt, $xpath_exp, $offset)= @_;
  5916.       my $sub= ($xpath{$xpath_exp} ||= _install_xpath( $xpath_exp));
  5917.       return $sub->( $elt) unless( defined $offset); 
  5918.       my @res= $sub->( $elt);
  5919.       return $res[$offset];
  5920.     }
  5921.     1; # so the module returns 1 as this is the last BEGIN block in the file
  5922. }
  5923.  
  5924.  
  5925. sub findvalue
  5926.   { my $elt= shift;
  5927.     return join '', map { $_->text } $elt->get_xpath( @_);
  5928.   }
  5929.  
  5930. #end-extract twig_node
  5931.  
  5932.  
  5933. # XML::XPath compatibility
  5934. sub getElementById     { return $_[0]->twig->elt_id( $_[1]); }
  5935. sub getChildNodes      { my @children= $_[0]->children; return wantarray ? @children : \@children; }
  5936.  
  5937. sub _flushed     { return $_[0]->{flushed}; }
  5938. sub _set_flushed { $_[0]->{flushed}=1;      }
  5939. sub _del_flushed { delete $_[0]->{flushed}; }
  5940.  
  5941.  
  5942. sub cut
  5943.   { my $elt= shift;
  5944.     my( $parent, $prev_sibling, $next_sibling, $last_elt);
  5945.  
  5946.     # you can't cut the root, sorry
  5947.     unless( $parent= $elt->{parent}) { return; }
  5948.  
  5949.     # save the old links, that'll make it easier for some loops
  5950.     foreach my $link ( qw(parent prev_sibling next_sibling) )
  5951.       { $elt->{former}->{$link}= $elt->{$link};
  5952.         weaken( $elt->{former}->{$link}) if( $XML::Twig::weakrefs);
  5953.       }
  5954.  
  5955.     # it we cut the current element then its parent becomes the current elt
  5956.     if( $elt->{twig_current})
  5957.       { my $twig_current= $elt->{parent};
  5958.         my $t= $elt->twig;
  5959.         $t->{twig_current}= $twig_current;
  5960.         $twig_current->{'twig_current'}=1;
  5961.         delete $elt->{'twig_current'};
  5962.       }
  5963.  
  5964.     if( $parent->{first_child} == $elt)
  5965.       { $parent->{first_child}=  $elt->{next_sibling};
  5966.         $parent->{empty}= 1 unless( $elt->{next_sibling});
  5967.       }
  5968.     $parent->set_last_child( $elt->{prev_sibling}) 
  5969.       if( $parent->{last_child} == $elt);
  5970.  
  5971.     if( $prev_sibling= $elt->{prev_sibling})
  5972.       { $prev_sibling->{next_sibling}=  $elt->{next_sibling}; }
  5973.     if( $next_sibling= $elt->{next_sibling})
  5974.       { $next_sibling->set_prev_sibling( $elt->{prev_sibling}); }
  5975.  
  5976.  
  5977.     $elt->set_parent( undef);
  5978.     $elt->set_prev_sibling( undef);
  5979.     $elt->{next_sibling}=  undef;
  5980.  
  5981.     return $elt;
  5982.   }
  5983.  
  5984. sub former_next_sibling { return $_[0]->{former}->{next_sibling}; }
  5985. sub former_prev_sibling { return $_[0]->{former}->{prev_sibling}; }
  5986. sub former_parent       { return $_[0]->{former}->{parent};       }
  5987.  
  5988. sub cut_children
  5989.   { my( $elt, $exp)= @_;
  5990.     my @children= $elt->children( $exp);
  5991.     foreach (@children) { $_->cut; }
  5992.     return @children;
  5993.   }
  5994.  
  5995. sub erase
  5996.   { my $elt= shift;
  5997.     #you cannot erase the current element
  5998.     if( $elt->{twig_current})
  5999.       { croak "trying to erase an element before it has been completely parsed"; }
  6000.     unless( $elt->{parent})
  6001.       { # trying to erase the root (of a twig or of a cut/new element)
  6002.         my @children= $elt->children;
  6003.         unless( @children == 1)
  6004.           { croak "can only erase an element with no parent if it has a single child"; }
  6005.         $elt->_move_extra_data_after_erase;
  6006.         my $child= shift @children;
  6007.         $child->set_parent( undef);
  6008.         my $twig= $elt->twig;
  6009.         $twig->set_root( $child);
  6010.       }
  6011.     else     
  6012.       { # normal case
  6013.         $elt->_move_extra_data_after_erase;
  6014.         my @children= $elt->children;
  6015.         if( @children)
  6016.           { # elt has children, move them up
  6017.             if( $elt->{prev_sibling})
  6018.               { # connect first child to previous sibling
  6019.                 $elt->{first_child}->set_prev_sibling( $elt->{prev_sibling});      
  6020.                 $elt->{prev_sibling}->set_next_sibling( $elt->{first_child}); 
  6021.               }
  6022.             else
  6023.               { # elt was the first child
  6024.                 $elt->{parent}->set_first_child( $elt->{first_child});
  6025.               }
  6026.             if( $elt->{next_sibling})
  6027.               { # connect last child to next sibling
  6028.                 $elt->{last_child}->set_next_sibling( $elt->{next_sibling});      
  6029.                 $elt->{next_sibling}->set_prev_sibling( $elt->{last_child}); 
  6030.               }
  6031.             else
  6032.               { # elt was the last child
  6033.                 $elt->{parent}->set_last_child( $elt->{last_child});
  6034.               }
  6035.             # update parent for all siblings
  6036.             foreach my $child (@children)
  6037.               { $child->set_parent( $elt->{parent}); }
  6038.             # elt is not referenced any more, so it will be DESTROYed
  6039.             # so we'd better break the links to its children
  6040.             undef $elt->{'first_child'};
  6041.             undef $elt->{'last_child'};
  6042.             undef $elt->{'parent'};
  6043.             undef $elt->{'prev_sibling'};
  6044.             undef $elt->{'next_sibling'};
  6045.           }
  6046.           { # elt had no child, delete it
  6047.              $elt->delete;
  6048.           }
  6049.               
  6050.       }
  6051.     return $elt;
  6052.  
  6053.   }
  6054.  
  6055. sub _move_extra_data_after_erase
  6056.   { my( $elt)= @_;
  6057.     # extra_data
  6058.     if( my $extra_data= $elt->{extra_data}) 
  6059.       { my $target= $elt->{first_child} || $elt->{next_sibling};
  6060.         if( $target)
  6061.           {
  6062.             if( $target->is( '#ELT'))
  6063.               { $target->set_extra_data( $extra_data . ($target->extra_data || '')); }
  6064.             elsif( $target->is( '#TEXT'))
  6065.               { $target->{extra_data_in_pcdata} ||=[];
  6066.                 unshift @{$target->{extra_data_in_pcdata}}, { text => $extra_data, offset => 0 };
  6067.              }
  6068.           }
  6069.         else
  6070.           { my $parent= $elt->{parent}; # always exists or the erase cannot be performed
  6071.             $parent->{extra_data_before_end_tag}= $extra_data . ($parent->{extra_data_before_end_tag}||''); 
  6072.           }
  6073.       }
  6074.       
  6075.      # extra_data_before_end_tag
  6076.     if( my $extra_data= $elt->{extra_data_before_end_tag}) 
  6077.       { if( my $target= $elt->{next_sibling})
  6078.           { if( $target->is( '#ELT'))
  6079.               { $target->set_extra_data( $extra_data . ($target->extra_data || '')); }
  6080.             elsif( $target->is( '#TEXT'))
  6081.               { $target->{extra_data_in_pcdata} ||=[];
  6082.                 unshift @{$target->{extra_data_in_pcdata}}, { text => $extra_data, offset => 0 };
  6083.              }
  6084.           }
  6085.         elsif( my $parent= $elt->{parent})
  6086.           { $parent->{extra_data_before_end_tag}= $extra_data . ($parent->{extra_data_before_end_tag}||''); }
  6087.        }
  6088.  
  6089.     return $elt;
  6090.  
  6091.   }
  6092. BEGIN
  6093.   { my %method= ( before      => \&paste_before,
  6094.                   after       => \&paste_after,
  6095.                   first_child => \&paste_first_child,
  6096.                   last_child  => \&paste_last_child,
  6097.                   within      => \&paste_within,
  6098.         );
  6099.     
  6100.     # paste elt somewhere around ref
  6101.     # pos can be first_child (default), last_child, before, after or within
  6102.     sub paste
  6103.       { my $elt= shift;
  6104.         if( $elt->{parent}) 
  6105.           { croak "cannot paste an element that belongs to a tree"; }
  6106.         my $pos;
  6107.         my $ref;
  6108.         if( ref $_[0]) 
  6109.           { $pos= 'first_child'; 
  6110.             croak "wrong argument order in paste, should be $_[1] first" if($_[1]); 
  6111.           }
  6112.         else
  6113.           { $pos= shift; }
  6114.  
  6115.         if( my $method= $method{$pos})
  6116.           {
  6117.             unless( isa( $_[0], "XML::Twig::Elt"))
  6118.               { if( ! defined( $_[0]))
  6119.                   { croak "missing target in paste"; }
  6120.                 elsif( ! ref( $_[0]))
  6121.                   { croak "wrong target type in paste (not a reference), should be XML::Twig::Elt or a subclass"; }
  6122.                 else
  6123.                   { my $ref= ref $_[0];
  6124.                     croak "wrong target type in paste: '$ref', should be XML::Twig::Elt or a subclass";
  6125.                   }
  6126.               }
  6127.             $ref= $_[0];
  6128.             # check here so error message lists the caller file/line
  6129.             if( !$ref->{parent} && ($pos=~ m{^(before|after)$}) && !(exists $elt->{'target'}) && !(exists $elt->{'comment'})) 
  6130.               { croak "cannot paste $1 root"; }
  6131.             $elt->$method( @_); 
  6132.           }
  6133.         else
  6134.           { croak "tried to paste in wrong position '$pos', allowed positions " . 
  6135.               " are 'first_child', 'last_child', 'before', 'after' and "    .
  6136.               "'within'";
  6137.           }
  6138.         if( (my $ids= $elt->{twig_id_list}) && (my $t= $ref->twig) )
  6139.           { $t->{twig_id_list}||={};
  6140.             @{$t->{twig_id_list}}{keys %$ids}= values %$ids;
  6141.           }
  6142.         return $elt;
  6143.       }
  6144.   
  6145.  
  6146.     sub paste_before
  6147.       { my( $elt, $ref)= @_;
  6148.         my( $parent, $prev_sibling, $next_sibling );
  6149.         
  6150.         # trying to paste before an orphan (root or detached wlt)
  6151.         unless( $ref->{parent}) 
  6152.           { if( my $t= $ref->twig)
  6153.               { if( (exists $elt->{'comment'}) || (exists $elt->{'target'})) # we can still do this
  6154.                   { $t->_add_cpi_outside_of_root( leading_cpi => $elt); return; }
  6155.                 else
  6156.                   { croak "cannot paste before root"; }
  6157.               }
  6158.             else
  6159.               { croak "cannot paste before an orphan element"; }
  6160.           }
  6161.         $parent= $ref->{parent};
  6162.         $prev_sibling= $ref->{prev_sibling};
  6163.         $next_sibling= $ref;
  6164.  
  6165.         $elt->set_parent( $parent);
  6166.         $parent->{first_child}=  $elt if( $parent->{first_child} == $ref);
  6167.  
  6168.         $prev_sibling->{next_sibling}=  $elt if( $prev_sibling);
  6169.         $elt->set_prev_sibling( $prev_sibling);
  6170.  
  6171.         $next_sibling->set_prev_sibling( $elt);
  6172.         $elt->{next_sibling}=  $ref;
  6173.         return $elt;
  6174.       }
  6175.      
  6176.      sub paste_after
  6177.       { my( $elt, $ref)= @_;
  6178.         my( $parent, $prev_sibling, $next_sibling );
  6179.  
  6180.         # trying to paste after an orphan (root or detached wlt)
  6181.         unless( $ref->{parent}) 
  6182.             { if( my $t= $ref->twig)
  6183.                 { if( (exists $elt->{'comment'}) || (exists $elt->{'target'})) # we can still do this
  6184.                     { $t->_add_cpi_outside_of_root( trailing_cpi => $elt); return; }
  6185.                   else
  6186.                     { croak "cannot paste after root"; }
  6187.                 }
  6188.               else
  6189.                 { croak "cannot paste after an orphan element"; }
  6190.             }
  6191.         $parent= $ref->{parent};
  6192.         $prev_sibling= $ref;
  6193.         $next_sibling= $ref->{next_sibling};
  6194.  
  6195.         $elt->set_parent( $parent);
  6196.         $parent->set_last_child( $elt) if( $parent->{last_child}== $ref);
  6197.  
  6198.         $prev_sibling->{next_sibling}=  $elt;
  6199.         $elt->set_prev_sibling( $prev_sibling);
  6200.  
  6201.         $next_sibling->set_prev_sibling( $elt) if( $next_sibling);
  6202.         $elt->{next_sibling}=  $next_sibling;
  6203.         return $elt;
  6204.  
  6205.       }
  6206.  
  6207.     sub paste_first_child
  6208.       { my( $elt, $ref)= @_;
  6209.         my( $parent, $prev_sibling, $next_sibling );
  6210.         $parent= $ref;
  6211.         $next_sibling= $ref->{first_child};
  6212.         delete $ref->{empty};
  6213.  
  6214.         $elt->set_parent( $parent);
  6215.         $parent->{first_child}=  $elt;
  6216.         $parent->set_last_child( $elt) unless( $parent->{last_child});
  6217.  
  6218.         $elt->set_prev_sibling( undef);
  6219.  
  6220.         $next_sibling->set_prev_sibling( $elt) if( $next_sibling);
  6221.         $elt->{next_sibling}=  $next_sibling;
  6222.         return $elt;
  6223.       }
  6224.       
  6225.     sub paste_last_child
  6226.       { my( $elt, $ref)= @_;
  6227.         my( $parent, $prev_sibling, $next_sibling );
  6228.         $parent= $ref;
  6229.         $prev_sibling= $ref->{last_child};
  6230.         delete $ref->{empty};
  6231.  
  6232.         $elt->set_parent( $parent);
  6233.         $parent->set_last_child( $elt);
  6234.         $parent->{first_child}=  $elt unless( $parent->{first_child});
  6235.  
  6236.         $elt->set_prev_sibling( $prev_sibling);
  6237.         $prev_sibling->{next_sibling}=  $elt if( $prev_sibling);
  6238.  
  6239.         $elt->{next_sibling}=  undef;
  6240.         return $elt;
  6241.       }
  6242.  
  6243.     sub paste_within
  6244.       { my( $elt, $ref, $offset)= @_;
  6245.         my $text= $ref->is_text ? $ref : $ref->next_elt( '#TEXT', $ref);
  6246.         my $new= $text->split_at( $offset);
  6247.         $elt->paste_before( $new);
  6248.         return $elt;
  6249.       }
  6250.   }
  6251.  
  6252. # load an element into a structure similar to XML::Simple's
  6253. sub simplify
  6254.   { my $elt= shift;
  6255.  
  6256.     # normalize option names
  6257.     my %options= @_;
  6258.     %options= map { my ($key, $val)= ($_, $options{$_});
  6259.                        $key=~ s{(\w)([A-Z])}{$1_\L$2}g;
  6260.                        $key => $val
  6261.                      } keys %options;
  6262.  
  6263.     # check options
  6264.     my @allowed_options= qw( keyattr forcearray noattr content_key
  6265.                              var var_regexp variables var_attr 
  6266.                              group_tags forcecontent
  6267.                              normalise_space normalize_space
  6268.                    );
  6269.     my %allowed_options= map { $_ => 1 } @allowed_options;
  6270.     foreach my $option (keys %options)
  6271.       { warn "invalid option $option\n" unless( $allowed_options{$option}); }
  6272.  
  6273.     $options{normalise_space} ||= $options{normalize_space} || 0;
  6274.     
  6275.     $options{content_key} ||= 'content';
  6276.     if( $options{content_key}=~ m{^-})
  6277.       { # need to remove the - and to activate extra folding
  6278.         $options{content_key}=~ s{^-}{};
  6279.         $options{extra_folding}= 1;
  6280.       }
  6281.     else
  6282.       { $options{extra_folding}= 0; }
  6283.    
  6284.     $options{forcearray} ||=0; 
  6285.     if( isa( $options{forcearray}, 'ARRAY'))
  6286.       { my %forcearray_tags= map { $_ => 1 } @{$options{forcearray}};
  6287.         $options{forcearray_tags}= \%forcearray_tags;
  6288.         $options{forcearray}= 0;
  6289.       }
  6290.  
  6291.     $options{keyattr}     ||= ['name', 'key', 'id'];
  6292.     if( ref $options{keyattr} eq 'ARRAY')
  6293.       { foreach my $keyattr (@{$options{keyattr}})
  6294.           { my( $prefix, $att)= ($keyattr=~ m{^([+-])?(.*)});
  6295.             $prefix ||= '';
  6296.             $options{key_for_all}->{$att}= 1;
  6297.             $options{remove_key_for_all}->{$att}=1 unless( $prefix eq '+');
  6298.             $options{prefix_key_for_all}->{$att}=1 if( $prefix eq '-');
  6299.           }
  6300.       }
  6301.     elsif( ref $options{keyattr} eq 'HASH')
  6302.       { while( my( $elt, $keyattr)= each %{$options{keyattr}})
  6303.          { my( $prefix, $att)= ($keyattr=~ m{^([+-])?(.*)});
  6304.            $prefix ||='';
  6305.            $options{key_for_elt}->{$elt}= $att;
  6306.            $options{remove_key_for_elt}->{"$elt#$att"}=1 unless( $prefix);
  6307.            $options{prefix_key_for_elt}->{"$elt#$att"}=1 if( $prefix eq '-');
  6308.          }
  6309.       }
  6310.        
  6311.  
  6312.     $options{var}||= $options{var_attr}; # for compat with XML::Simple
  6313.     if( $options{var}) { $options{var_values}= {}; }
  6314.     else               { $options{var}='';         }
  6315.  
  6316.     if( $options{variables}) 
  6317.       { $options{var}||= 1;
  6318.         $options{var_values}= $options{variables};
  6319.       }
  6320.  
  6321.     if( $options{var_regexp} and !$options{var})
  6322.       { warn "var option not used, var_regexp option ignored\n"; }
  6323.     $options{var_regexp} ||= '\$\{?(\w+)\}?';
  6324.       
  6325.     $elt->_simplify( \%options);
  6326.  
  6327.  }
  6328.  
  6329. sub _simplify
  6330.   { my( $elt, $options)= @_;
  6331.  
  6332.     my $data;
  6333.  
  6334.     my $gi= $XML::Twig::index2gi[$elt->{'gi'}];
  6335.     my @children= $elt->children;
  6336.     my %atts= $options->{noattr} ? () : %{$elt->atts};
  6337.     my $nb_atts= keys %atts;
  6338.     my $nb_children= $elt->children_count + $nb_atts;
  6339.  
  6340.     my %nb_children;
  6341.     foreach (@children)   { $nb_children{$_->tag}++; }
  6342.     foreach (keys %atts)  { $nb_children{$_}++;      }
  6343.  
  6344.     my $arrays; # tag => array where elements are stored
  6345.  
  6346.  
  6347.     # store children
  6348.     foreach my $child (@children)
  6349.       { if( $child->is_text)
  6350.           { # generate with a content key
  6351.             my $text= $elt->_text_with_vars( $options);
  6352.             $text= _normalize_space( $text) if( $options->{normalise_space} >= 2);
  6353.             if(    $options->{force_content}
  6354.                 || $nb_atts 
  6355.                 || (scalar @children > 1)
  6356.               )
  6357.               { $data->{$options->{content_key}}= $text; }
  6358.             else
  6359.               { $data= $text; }
  6360.           }
  6361.         else
  6362.           { # element with sub elements
  6363.             my $child_gi= $XML::Twig::index2gi[$child->{'gi'}];
  6364.  
  6365.             my $child_data= $child->_simplify( $options);
  6366.  
  6367.             # first see if we need to simplify further the child data
  6368.             # simplify because of grouped tags
  6369.             if( my $grouped_tag= $options->{group_tags}->{$child_gi})
  6370.               { # check that the child data is a hash with a single field
  6371.                 unless(    (ref( $child_data) eq 'HASH')
  6372.                         && (keys %$child_data == 1)
  6373.                         && defined ( my $grouped_child_data= $child_data->{$grouped_tag})
  6374.                       )
  6375.                   { die "error in grouped tag $child_gi"; }
  6376.                 else
  6377.                   { $child_data=  $grouped_child_data; }
  6378.               }
  6379.             # simplify because of extra folding
  6380.             if( $options->{extra_folding})
  6381.               { if(    (ref( $child_data) eq 'HASH')
  6382.                     && (keys %$child_data == 1)
  6383.                     && defined( my $content= $child_data->{$options->{content_key}})
  6384.                   )
  6385.                   { $child_data= $content; }
  6386.               }
  6387.  
  6388.  
  6389.             if( my $keyatt= $child->_key_attr( $options))
  6390.               { # simplify element with key
  6391.                 my $key= $child->{'att'}->{$keyatt};
  6392.                 $key= _normalize_space( $key) if( $options->{normalise_space} >= 1);
  6393.                 $data->{$child_gi}->{$key}= $child_data;
  6394.               }
  6395.             elsif(      $options->{forcearray}
  6396.                    ||   $options->{forcearray_tags}->{$child_gi}
  6397.                    || ( $nb_children{$child_gi} > 1)
  6398.                  )
  6399.               { # simplify element to store in an array
  6400.                 $data->{$child_gi} ||= [];
  6401.                 push @{$data->{$child_gi}}, $child_data;
  6402.               }
  6403.             else
  6404.               { # simplify element to store as a hash field
  6405.                 $data->{$child_gi}= $child_data;
  6406.               }
  6407.  
  6408.           }
  6409.     }
  6410.  
  6411.     # store atts
  6412.     # TODO: deal with att that already have an element by that name
  6413.     foreach my $att (keys %atts)
  6414.       { # do not store if the att is a key that needs to be removed
  6415.         if(    $options->{remove_key_for_all}->{$att}
  6416.             || $options->{remove_key_for_elt}->{"$gi#$att"}
  6417.           )
  6418.           { next; }
  6419.  
  6420.         my $att_text= _replace_vars_in_text( $atts{$att}, $options);
  6421.         $att_text= _normalize_space( $att_text) if( $options->{normalise_space} >= 2);
  6422.         
  6423.         if(    $options->{prefix_key_for_all}->{$att}
  6424.             || $options->{prefix_key_for_elt}->{"$gi#$att"}
  6425.           )
  6426.           { # prefix the att
  6427.             $data->{"-$att"}= $att_text;
  6428.           } 
  6429.         else
  6430.           { # normal case
  6431.             $data->{$att}= $att_text; 
  6432.           }
  6433.       }
  6434.     
  6435.     return $data;
  6436.   }
  6437.  
  6438. sub _key_attr
  6439.   { my( $elt, $options)=@_;
  6440.     return if( $options->{noattr});
  6441.     if( $options->{key_for_all})
  6442.       { foreach my $att ($elt->att_names)
  6443.           { if( $options->{key_for_all}->{$att})
  6444.               { return $att; }
  6445.           }
  6446.       }
  6447.     elsif( $options->{key_for_elt})
  6448.       { if( my $key_for_elt= $options->{key_for_elt}->{$XML::Twig::index2gi[$elt->{'gi'}]} )
  6449.           { return $key_for_elt if( defined( $elt->{'att'}->{$key_for_elt})); }
  6450.       }
  6451.     return;
  6452.   }
  6453.  
  6454. sub _text_with_vars
  6455.   { my( $elt, $options)= @_;
  6456.     my $text;
  6457.     if( $options->{var}) 
  6458.       { $text= _replace_vars_in_text( $elt->text, $options); 
  6459.         $elt->_store_var( $options);
  6460.       }
  6461.      else
  6462.       { $text= $elt->text; }
  6463.     return $text;
  6464.   }
  6465.  
  6466.  
  6467. sub _normalize_space
  6468.   { my $text= shift;
  6469.     $text=~ s{\s+}{ }sg;
  6470.     $text=~ s{^\s}{};
  6471.     $text=~ s{\s$}{};
  6472.     return $text;
  6473.   }
  6474.  
  6475.  
  6476. sub att_nb
  6477.   { return 0 unless( my $atts= $_[0]->atts);
  6478.     return scalar keys %$atts;
  6479.   }
  6480.     
  6481. sub has_no_atts
  6482.   { return 1 unless( my $atts= $_[0]->atts);
  6483.     return scalar keys %$atts ? 0 : 1;
  6484.  }
  6485.     
  6486. sub _replace_vars_in_text
  6487.   { my( $text, $options)= @_;
  6488.  
  6489.     $text=~ s{($options->{var_regexp})}
  6490.              { if( defined( my $value= $options->{var_values}->{$2}))
  6491.                  { $value }
  6492.                else
  6493.                  { warn "unknown variable $2\n";
  6494.                    $1
  6495.                  }
  6496.              }gex;
  6497.     return $text;
  6498.   }
  6499.  
  6500. sub _store_var
  6501.   { my( $elt, $options)= @_;
  6502.     if( defined (my $var_name= $elt->{'att'}->{$options->{var}}))
  6503.        { $options->{var_values}->{$var_name}= $elt->text; 
  6504.        }
  6505.   }
  6506.  
  6507.  
  6508. # split a text element at a given offset
  6509. sub split_at
  6510.   { my( $elt, $offset)= @_;
  6511.     my $text_elt= $elt->is_text ? $elt : $elt->first_child( TEXT) || return '';
  6512.     my $string= $text_elt->text; 
  6513.     my $left_string= substr( $string, 0, $offset);
  6514.     my $right_string= substr( $string, $offset);
  6515.     $text_elt->set_pcdata( $left_string);
  6516.     my $new_elt= $elt->new( $XML::Twig::index2gi[$elt->{'gi'}], $right_string);
  6517.     $new_elt->paste( after => $elt);
  6518.     return $new_elt;
  6519.   }
  6520.  
  6521.     
  6522. # split an element or its text descendants into several, in place
  6523. # all elements (new and untouched) are returned
  6524. sub split    
  6525.   { my $elt= shift;
  6526.     my @text_chunks;
  6527.     my @result;
  6528.     if( $elt->is_text) { @text_chunks= ($elt); }
  6529.     else               { @text_chunks= $elt->descendants( '#TEXT'); }
  6530.     foreach my $text_chunk (@text_chunks)
  6531.       { push @result, $text_chunk->_split( 1, @_); }
  6532.     return @result;
  6533.   }
  6534.  
  6535. # split an element or its text descendants into several, in place
  6536. # created elements (those which match the regexp) are returned
  6537. sub mark
  6538.   { my $elt= shift;
  6539.     my @text_chunks;
  6540.     my @result;
  6541.     if( $elt->is_text) { @text_chunks= ($elt); }
  6542.     else               { @text_chunks= $elt->descendants( '#TEXT'); }
  6543.     foreach my $text_chunk (@text_chunks)
  6544.       { push @result, $text_chunk->_split( 0, @_); }
  6545.     return @result;
  6546.   }
  6547.  
  6548. # split a single text element
  6549. # return_all defines what is returned: if it is true 
  6550. # only returns the elements created by matches in the split regexp
  6551. # otherwise all elements (new and untouched) are returned
  6552.  
  6553. { my $encode_is_loaded=0;   # so we only load Encode once in 5.8.0+
  6554.  
  6555.   sub _split
  6556.     { my $elt= shift;
  6557.       my $return_all= shift;
  6558.       my $regexp= shift;
  6559.       my @tags;
  6560.  
  6561.       while( my $tag= shift())
  6562.         { if( ref $_[0]) 
  6563.             { push @tags, { tag => $tag, atts => shift }; }
  6564.           else
  6565.             { push @tags, { tag => $tag }; }
  6566.         }
  6567.  
  6568.       unless( @tags) { @tags= { tag => $elt->parent( '#ELT')->gi }; }
  6569.           
  6570.       my @result;                                 # the returned list of elements
  6571.       my $text= $elt->text;
  6572.       my $gi= $XML::Twig::index2gi[$elt->{'gi'}];
  6573.   
  6574.       # 2 uses: if split matches then the first substring reuses $elt
  6575.       #         once a split has occured then the last match needs to be put in
  6576.       #         a new element      
  6577.       my $previous_match= 0;
  6578.  
  6579.       while( my( $pre_match, @matches)= $text=~ /^(.*?)$regexp(.*)$/gcs)
  6580.         { $text= pop @matches;
  6581.           if( $previous_match)
  6582.             { # match, not the first one, create a new text ($gi) element
  6583.               $pre_match= _utf8_ify( $pre_match);
  6584.               $elt= $elt->insert_new_elt( after => $gi, $pre_match);
  6585.               push @result, $elt if( $return_all);
  6586.             }
  6587.           else
  6588.             { # first match in $elt, re-use $elt for the first sub-string
  6589.               $elt->set_text( _utf8_ify( $pre_match));
  6590.               $previous_match++;                # store the fact that there was a match
  6591.               push @result, $elt if( $return_all);
  6592.             }
  6593.  
  6594.           # now deal with matches captured in the regexp
  6595.           if( @matches)
  6596.             { # match, with capture
  6597.               my $i=0;
  6598.               foreach my $match (@matches)
  6599.                 { # create new element, text is the match
  6600.                   $match= _utf8_ify( $match);
  6601.                   my $tag  = $tags[$i]->{tag};
  6602.                   my $atts = \%{$tags[$i]->{atts}} || {};
  6603.                   $elt= $elt->insert_new_elt( after => $tag, $atts, $match);
  6604.                   push @result, $elt;
  6605.                   $i= ($i + 1) % @tags;
  6606.                 }
  6607.             }
  6608.           else
  6609.             { # match, no captures
  6610.               my $tag  = $tags[0]->{tag};
  6611.               my $atts = \%{$tags[0]->{atts}} || {};
  6612.               $elt=  $elt->insert_new_elt( after => $tag, $atts);
  6613.               push @result, $elt;
  6614.             }
  6615.         }
  6616.       if( $previous_match && $text)
  6617.         { # there was at least 1 match, and there is text left after the match
  6618.           $elt= $elt->insert_new_elt( after => $gi, $text);
  6619.         }
  6620.  
  6621.       push @result, $elt if( $return_all);
  6622.  
  6623.       return @result; # return all elements
  6624.    }
  6625.  
  6626.   # evil hack needed in 5.8.0, the utf flag is not set on $<n>...
  6627.   sub _utf8_ify
  6628.     { my $string= shift;
  6629.       if( $] == 5.008 and !_keep_encoding()) 
  6630.         { unless( $encode_is_loaded) { require Encode; import Encode; $encode_is_loaded++; }
  6631.           Encode::_utf8_on( $string); # the flag should be set but is not
  6632.         }
  6633.       return $string;
  6634.     }
  6635.  
  6636.  
  6637. }
  6638.  
  6639. { my %replace_sub; # cache for complex expressions (expression => sub)
  6640.  
  6641.   sub subs_text
  6642.     { my( $elt, $regexp, $replace)= @_;
  6643.   
  6644.       my $replacement_string;
  6645.       my $is_string= _is_string( $replace);
  6646.       foreach my $text_elt ($elt->descendants_or_self( '#TEXT'))
  6647.         { if( $is_string)
  6648.             { my $text= $text_elt->text;
  6649.               $text=~ s{$regexp}{ _replace_var( $replace, $1, $2, $3, $4, $5, $6, $7, $8, $9)}egx;
  6650.               $text_elt->set_text( $text);
  6651.            }
  6652.           else
  6653.             { my $replace_sub= ( $replace_sub{$replace} ||= _install_replace_sub( $replace)); 
  6654.               my $text= $text_elt->text;
  6655.               my $pos=0;  # used to skip text that was previously matched
  6656.               while( my( $pre_match_string, $match_string, @var)= ($text=~ m{(.*?)($regexp)}sg))
  6657.                 { my $match_start  = length( $pre_match_string);
  6658.                   my $match        = $text_elt->split_at( $match_start + $pos);
  6659.                   my $match_length = length( $match_string);
  6660.                   my $post_match   = $match->split_at( $match_length);
  6661.                   $replace_sub->( $match, @var);
  6662.                   # merge previous text with current one
  6663.                   my $next_sibling;
  6664.                   if(    ($next_sibling= $text_elt->{next_sibling})
  6665.                       && ($XML::Twig::index2gi[$text_elt->{'gi'}] eq $XML::Twig::index2gi[$next_sibling->{'gi'}])
  6666.                     )
  6667.                     { $text_elt->merge_text( $next_sibling); }
  6668.                     
  6669.                   # if the match is at the beginning of the text an empty #PCDATA is left: remove it 
  6670.                   if( !$text_elt->text) { $text_elt->delete; } 
  6671.                   
  6672.                   # go to next 
  6673.                   $text_elt= $post_match;
  6674.                   $text= $post_match->text;
  6675.                   # merge last text element with next one if needed,
  6676.                   # the match will be against the non-matched text,
  6677.                   # so $pos is used to skip the merged part
  6678.                   my $prev_sibling;
  6679.                   if(    ($prev_sibling=  $post_match->{prev_sibling})
  6680.                       && ($XML::Twig::index2gi[$post_match->{'gi'}] eq $XML::Twig::index2gi[$prev_sibling->{'gi'}])
  6681.                     )
  6682.                     { $pos= length( $prev_sibling->text);
  6683.                       $prev_sibling->merge_text( $post_match); 
  6684.                     }
  6685.  
  6686.                   # if the match is at the end of the text an empty #PCDATA is left: remove it 
  6687.                   if( !$text_elt->text) { $text_elt->delete; } 
  6688.                   
  6689.                 }
  6690.               
  6691.             }
  6692.         }
  6693.       return $elt;
  6694.     }
  6695.  
  6696.  
  6697.   sub _is_string
  6698.     { return ($_[0]=~ m{&e[ln]t}) ? 0: 1 }
  6699.  
  6700.   sub _replace_var
  6701.     { my( $string, @var)= @_;
  6702.       unshift @var, undef;
  6703.       $string=~ s{\$(\d)}{$var[$1]}g;
  6704.       return $string;
  6705.     }
  6706.  
  6707.   sub _install_replace_sub
  6708.     { my $replace_exp= shift;
  6709.       my @item= split m{(&e[ln]t\s*\([^)]*\))}, $replace_exp;
  6710.       my $sub= q{ my( $match, @var)= @_; unshift @var, undef; my $new; };
  6711.       my( $gi, $exp);
  6712.       foreach my $item (@item)
  6713.         { if(    $item=~ m{^&elt\s*\(([^)]*)\)})
  6714.             { $exp= $1;
  6715.             }
  6716.           elsif( $item=~ m{^&ent\s*\(\s*([^\s)]*)\s*\)})
  6717.             { $exp= " '#ENT' => $1"; }
  6718.           else
  6719.             { $exp= qq{ '#PCDATA' => "$item"}; }
  6720.           $exp=~ s{\$(\d)}{\$var[$1]}g; # replace references to matches
  6721.           $sub.= qq{ \$new= \$match->new( $exp); };
  6722.           $sub .= q{ $new->paste( before => $match); };
  6723.         }
  6724.       $sub .= q{ $match->delete; };
  6725.       #$sub=~ s/;/;\n/g;
  6726.       my $coderef= eval "sub { $sub }";
  6727.       if( $@) { croak( "invalid replacement expression $replace_exp: ",$@); }
  6728.       return $coderef;
  6729.     }
  6730.  
  6731.   }
  6732.  
  6733.  
  6734. sub merge_text
  6735.   { my( $e1, $e2)= @_;
  6736.     croak "invalid merge: can only merge 2 elements" 
  6737.         unless( isa( $e2, 'XML::Twig::Elt'));
  6738.     croak "invalid merge: can only merge 2 text elements" 
  6739.         unless( $e1->is_text && $e2->is_text && ($e1->gi eq $e2->gi));
  6740.     $e1->set_text( $e1->text . $e2->text);
  6741.     $e2->delete;
  6742.     return $e1;
  6743.   }
  6744.  
  6745. sub merge
  6746.   { my( $e1, $e2)= @_;
  6747.     my @e2_children= $e2->children;
  6748.     if(     $e1->last_child && $e1->last_child->is_pcdata
  6749.         &&  @e2_children && $e2_children[0]->is_pcdata
  6750.       )
  6751.       { $e1->last_child->{pcdata} .= $e2_children[0]->{pcdata}; shift @e2_children; }
  6752.     foreach my $e (@e2_children) { $e->move( last_child => $e1); } 
  6753.     $e2->delete;
  6754.     return $e1;
  6755.   }
  6756.  
  6757.  
  6758. # recursively copy an element and returns the copy (can be huge and long)
  6759. sub copy
  6760.   { my $elt= shift;
  6761.     my $copy= $elt->new( $XML::Twig::index2gi[$elt->{'gi'}]);
  6762.  
  6763.     $copy->set_extra_data( $elt->extra_data) if( $elt->extra_data);
  6764.     $copy->{extra_data_before_end_tag}= $elt->{extra_data_before_end_tag} if( $elt->{extra_data_before_end_tag});
  6765.  
  6766.     $copy->set_asis                          if( $elt->is_asis);
  6767.     if( ($elt->{'empty'} || 0)) { $copy->{empty}= 1; } # do not swap or speedup will mess up this                         
  6768.  
  6769.     if( (exists $elt->{'pcdata'}))
  6770.       { $copy->set_pcdata( $elt->{pcdata}); 
  6771.         $copy->{extra_data_in_pcdata}= $elt->{extra_data_in_pcdata} if( $elt->{extra_data_in_pcdata});
  6772.       }
  6773.     elsif( (exists $elt->{'cdata'}))
  6774.       { $copy->_set_cdata( $elt->{cdata}); 
  6775.         $copy->{extra_data_in_pcdata}= $elt->{extra_data_in_pcdata} if( $elt->{extra_data_in_pcdata});
  6776.       }
  6777.     elsif( (exists $elt->{'target'}))
  6778.       { $copy->_set_pi( $elt->{target}, $elt->{data}); }
  6779.     elsif( (exists $elt->{'comment'}))
  6780.       { $copy->_set_comment( $elt->{comment}); }
  6781.     elsif( (exists $elt->{'ent'}))
  6782.       { $copy->{ent}=  $elt->{ent}; }
  6783.     else
  6784.       { my @children= $elt->children;
  6785.         if( my $atts= $elt->atts)
  6786.           { my %atts= %{$atts}; # we want to do a real copy of the attributes
  6787.             $copy->set_atts( \%atts);
  6788.           }
  6789.         foreach my $child (@children)
  6790.           { my $child_copy= $child->copy;
  6791.             $child_copy->paste( 'last_child', $copy);
  6792.           }
  6793.       }
  6794.     return $copy;
  6795.   }
  6796.  
  6797.  
  6798. sub delete
  6799.   { my $elt= shift;
  6800.     $elt->cut;
  6801.     $elt->DESTROY unless( $XML::Twig::weakrefs);
  6802.     return undef;
  6803.   }
  6804.  
  6805.   sub DESTROY
  6806.     { my $elt= shift;
  6807.       my $t= shift || $elt->twig; # optional argument, passed in recursive calls
  6808.       return if( $XML::Twig::weakrefs);
  6809.  
  6810.       foreach( @{[$elt->children]}) { $_->DESTROY( $t); }
  6811.  
  6812.       # the id reference needs to be destroyed
  6813.       # lots of tests to avoid warnings during the cleanup phase
  6814.       $elt->del_id( $t) if( $ID && $t && defined( $elt->{att}) && exists( $elt->{att}->{$ID}));
  6815.       undef $elt;
  6816.     }
  6817. }
  6818.  
  6819.  
  6820. # to be called only from a start_tag_handler: ignores the current element
  6821. sub ignore
  6822.   { my $elt= shift;
  6823.     my $t= $elt->twig;
  6824.     $t->ignore( $elt, @_);
  6825.   }
  6826.  
  6827. BEGIN {
  6828.   my $pretty                    = 0;
  6829.   my $quote                     = '"';
  6830.   my $INDENT                    = '  ';
  6831.   my $empty_tag_style           = 0;
  6832.   my $remove_cdata              = 0;
  6833.   my $keep_encoding             = 0;
  6834.   my $expand_external_entities  = 0;
  6835.   my $keep_atts_order           = 0;
  6836.   my $do_not_escape_amp_in_atts = 0;
  6837.   my $WRAP                      = '80';
  6838.  
  6839.   my ($NSGMLS, $NICE, $INDENTED, $INDENTEDC, $WRAPPED, $RECORD1, $RECORD2)= (1..7);
  6840.  
  6841.   my %pretty_print_style=
  6842.     ( none       => 0,          # no added \n
  6843.       nsgmls     => $NSGMLS,    # nsgmls-style, \n in tags
  6844.       # below this line styles are UNSAFE (the generated XML can be invalid)
  6845.       nice       => $NICE,      # \n after open/close tags except when the 
  6846.                                 # element starts with text
  6847.       indented   => $INDENTED,  # nice plus idented
  6848.       indented_c => $INDENTEDC, # slightly more compact than indented (closing
  6849.                                 # tags are on the same line)
  6850.       wrapped    => $WRAPPED,   # text is wrapped at column 
  6851.       record_c   => $RECORD1,   # for record-like data (compact)
  6852.       record     => $RECORD2,   # for record-like data  (not so compact)
  6853.     );
  6854.  
  6855.   my ($HTML, $EXPAND)= (1..2);
  6856.   my %empty_tag_style=
  6857.     ( normal => 0,        # <tag/>
  6858.       html   => $HTML,    # <tag />
  6859.       xhtml  => $HTML,    # <tag />
  6860.       expand => $EXPAND,  # <tag></tag>
  6861.     );
  6862.  
  6863.   my %quote_style=
  6864.     ( double  => '"',    
  6865.       single  => "'", 
  6866.       # smart  => "smart", 
  6867.     );
  6868.  
  6869.   my $xml_space_preserve; # set when an element includes xml:space="preserve"
  6870.  
  6871.   my $output_filter;      # filters the entire output (including < and >)
  6872.   my $output_text_filter; # filters only the text part (tag names, attributes, pcdata)
  6873.  
  6874.  
  6875.   # returns those pesky "global" variables so you can switch between twigs 
  6876.   sub global_state
  6877.     { return
  6878.        { pretty                    => $pretty,
  6879.          quote                     => $quote,
  6880.          indent                    => $INDENT,
  6881.          empty_tag_style           => $empty_tag_style,
  6882.          remove_cdata              => $remove_cdata,
  6883.          keep_encoding             => $keep_encoding,
  6884.          expand_external_entities  => $expand_external_entities,
  6885.          output_filter             => $output_filter,
  6886.          output_text_filter        => $output_text_filter,
  6887.          keep_atts_order           => $keep_atts_order,
  6888.          do_not_escape_amp_in_atts => $do_not_escape_amp_in_atts,
  6889.          wrap                      => $WRAP,
  6890.         };
  6891.     }
  6892.  
  6893.   # restores the global variables
  6894.   sub set_global_state
  6895.     { my $state= shift;
  6896.       $pretty                    = $state->{pretty};
  6897.       $quote                     = $state->{quote};
  6898.       $INDENT                    = $state->{indent};
  6899.       $empty_tag_style           = $state->{empty_tag_style};
  6900.       $remove_cdata              = $state->{remove_cdata};
  6901.       $keep_encoding             = $state->{keep_encoding};
  6902.       $expand_external_entities  = $state->{expand_external_entities};
  6903.       $output_filter             = $state->{output_filter};
  6904.       $output_text_filter        = $state->{output_text_filter};
  6905.       $keep_atts_order           = $state->{keep_atts_order};
  6906.       $do_not_escape_amp_in_atts = $state->{do_not_escape_amp_in_atts};
  6907.       $WRAP                      = $state->{wrap};
  6908.     }
  6909.  
  6910.   # sets global state to defaults
  6911.   sub init_global_state
  6912.     { set_global_state(
  6913.        { pretty                    => 0,
  6914.          quote                     => '"',
  6915.          indent                    => $INDENT,
  6916.          empty_tag_style           => 0,
  6917.          remove_cdata              => 0,
  6918.          keep_encoding             => 0,
  6919.          expand_external_entities  => 0,
  6920.          output_filter             => undef,
  6921.          output_text_filter        => undef,
  6922.          keep_atts_order           => undef,
  6923.          do_not_escape_amp_in_atts => 0,
  6924.          wrap                      => $WRAP,
  6925.         });
  6926.     }
  6927.  
  6928.  
  6929.   # set the pretty_print style (in $pretty) and returns the old one
  6930.   # can be called from outside the package with 2 arguments (elt, style)
  6931.   # or from inside with only one argument (style)
  6932.   # the style can be either a string (one of the keys of %pretty_print_style
  6933.   # or a number (presumably an old value saved)
  6934.   sub set_pretty_print
  6935.     { my $style= lc( defined $_[1] ? $_[1] : $_[0]); # so we cover both cases 
  6936.       my $old_pretty= $pretty;
  6937.       if( $style=~ /^\d+$/)
  6938.         { croak "invalid pretty print style $style"
  6939.         unless( $style < keys %pretty_print_style);
  6940.         $pretty= $style;
  6941.     }
  6942.       else
  6943.         { croak "invalid pretty print style '$style'"
  6944.             unless( exists $pretty_print_style{$style});
  6945.           $pretty= $pretty_print_style{$style};
  6946.     }
  6947.       if( $pretty == $WRAPPED) 
  6948.         { XML::Twig::_use( 'Text::Wrap') or croak( "Text::Wrap not available, cannot use 'wrapped' style"); }
  6949.       return $old_pretty;
  6950.     }
  6951.   
  6952.   
  6953.   # set the empty tag style (in $empty_tag_style) and returns the old one
  6954.   # can be called from outside the package with 2 arguments (elt, style)
  6955.   # or from inside with only one argument (style)
  6956.   # the style can be either a string (one of the keys of %empty_tag_style
  6957.   # or a number (presumably an old value saved)
  6958.   sub set_empty_tag_style
  6959.     { my $style= lc( defined $_[1] ? $_[1] : $_[0]); # so we cover both cases 
  6960.       my $old_style= $empty_tag_style;
  6961.       if( $style=~ /^\d+$/)
  6962.         { croak "invalid empty tag style $style"
  6963.         unless( $style < keys %empty_tag_style);
  6964.         $empty_tag_style= $style;
  6965.         }
  6966.       else
  6967.         { croak "invalid empty tag style '$style'"
  6968.             unless( exists $empty_tag_style{$style});
  6969.           $empty_tag_style= $empty_tag_style{$style};
  6970.         }
  6971.       return $old_style;
  6972.     }
  6973.       
  6974.   sub set_quote
  6975.     { my $style= $_[1] || $_[0];
  6976.       my $old_quote= $quote;
  6977.       croak "invalid quote '$style'" unless( exists $quote_style{$style});
  6978.       $quote= $quote_style{$style};
  6979.       return $old_quote;
  6980.     }
  6981.     
  6982.   sub set_remove_cdata
  6983.     { my $new_value= defined $_[1] ? $_[1] : $_[0];
  6984.       my $old_value= $remove_cdata;
  6985.       $remove_cdata= $new_value;
  6986.       return $old_value;
  6987.     }
  6988.       
  6989.       
  6990.   sub set_indent
  6991.     { my $new_value= defined $_[1] ? $_[1] : $_[0];
  6992.       my $old_value= $INDENT;
  6993.       $INDENT= $new_value;
  6994.       return $old_value;
  6995.     }
  6996.  
  6997.   sub set_wrap
  6998.     { my $new_value= defined $_[1] ? $_[1] : $_[0];
  6999.       my $old_value= $WRAP;
  7000.       $WRAP= $new_value;
  7001.       return $old_value;
  7002.     }
  7003.        
  7004.        
  7005.   sub set_keep_encoding
  7006.     { my $new_value= defined $_[1] ? $_[1] : $_[0];
  7007.       my $old_value= $keep_encoding;
  7008.       $keep_encoding= $new_value;
  7009.       return $old_value;
  7010.    }
  7011.  
  7012.   sub _keep_encoding { return $keep_encoding; } # so I can use elsewhere in the module
  7013.  
  7014.   sub set_do_not_escape_amp_in_atts
  7015.     { my $new_value= defined $_[1] ? $_[1] : $_[0];
  7016.       my $old_value= $do_not_escape_amp_in_atts;
  7017.       $do_not_escape_amp_in_atts= $new_value;
  7018.       return $old_value;
  7019.    }
  7020.  
  7021.   sub output_filter      { return $output_filter; }
  7022.   sub output_text_filter { return $output_text_filter; }
  7023.  
  7024.   sub set_output_filter
  7025.     { my $new_value= defined $_[1] ? $_[1] : $_[0]; # can be called in object/non-object mode
  7026.       # if called in object mode with no argument, the filter is undefined
  7027.       if( isa( $new_value, 'XML::Twig::Elt') || isa( $new_value, 'XML::Twig')) { undef $new_value; }
  7028.       my $old_value= $output_filter;
  7029.       if( !$new_value || isa( $new_value, 'CODE') )
  7030.         { $output_filter= $new_value; }
  7031.       elsif( $new_value eq 'latin1')
  7032.         { $output_filter= XML::Twig::latin1();
  7033.         }
  7034.       elsif( $XML::Twig::filter{$new_value})
  7035.         {  $output_filter= $XML::Twig::filter{$new_value}; }
  7036.       else
  7037.         { croak "invalid output filter '$new_value'"; }
  7038.       
  7039.       return $old_value;
  7040.     }
  7041.        
  7042.   sub set_output_text_filter
  7043.     { my $new_value= defined $_[1] ? $_[1] : $_[0]; # can be called in object/non-object mode
  7044.       # if called in object mode with no argument, the filter is undefined
  7045.       if( isa( $new_value, 'XML::Twig::Elt') || isa( $new_value, 'XML::Twig')) { undef $new_value; }
  7046.       my $old_value= $output_text_filter;
  7047.       if( !$new_value || isa( $new_value, 'CODE') )
  7048.         { $output_text_filter= $new_value; }
  7049.       elsif( $new_value eq 'latin1')
  7050.         { $output_text_filter= XML::Twig::latin1();
  7051.         }
  7052.       elsif( $XML::Twig::filter{$new_value})
  7053.         {  $output_text_filter= $XML::Twig::filter{$new_value}; }
  7054.       else
  7055.         { croak "invalid output text filter '$new_value'"; }
  7056.       
  7057.       return $old_value;
  7058.     }
  7059.        
  7060.   sub set_expand_external_entities
  7061.     { my $new_value= defined $_[1] ? $_[1] : $_[0];
  7062.       my $old_value= $expand_external_entities;
  7063.       $expand_external_entities= $new_value;
  7064.       return $old_value;
  7065.     }
  7066.        
  7067.   sub set_keep_atts_order
  7068.     { my $new_value= defined $_[1] ? $_[1] : $_[0];
  7069.       my $old_value= $keep_atts_order;
  7070.       $keep_atts_order= $new_value;
  7071.       return $old_value;
  7072.     
  7073.    }
  7074.  
  7075.   sub keep_atts_order { return $keep_atts_order; } # so I can use elsewhere in the module
  7076.  
  7077.   # $elt is an element to print
  7078.   # $pretty is an optional value, if true a \n is printed after the <
  7079.  
  7080.   my %html_empty_elt;
  7081.   BEGIN { %html_empty_elt= map { $_ => 1} qw( base meta link hr br param img area input col); }
  7082.  
  7083.   sub start_tag
  7084.     { my $elt= shift;
  7085.       my $option= shift;
  7086.   
  7087.       return if( $elt->{gi}<$XML::Twig::SPECIAL_GI);
  7088.  
  7089.       my $extra_data= $elt->{extra_data} || '';
  7090.  
  7091.       my $gi= $XML::Twig::index2gi[$elt->{'gi'}];
  7092.  
  7093.       my $ns_map= $elt->{'att'}->{'#original_gi'};
  7094.       if( $ns_map) { $gi= _restore_original_prefix( $ns_map, $gi); }
  7095.       $gi=~ s{^#default:}{}; # remove default prefix
  7096.  
  7097.       if( $output_text_filter) { $gi= $output_text_filter->( $gi); }
  7098.  
  7099.       my $tag="<" . $gi;
  7100.   
  7101.       # get the attribute and their values
  7102.       my $att= $elt->atts;
  7103.       if( $att)
  7104.         { foreach my $att_name ( $keep_atts_order ?  keys %{$att} : sort keys %{$att}) 
  7105.            { # skip private attributes (they start with #)
  7106.              next if( ( (substr( $att_name, 0, 1) eq '#') && (substr( $att_name, 0, 9) ne '#default:') ));
  7107.  
  7108.              $tag .=  $pretty==$NSGMLS ? "\n" : ' ';
  7109.  
  7110.              my $output_att_name= $ns_map ? _restore_original_prefix( $ns_map, $att_name) : $att_name;
  7111.              if( $output_text_filter) { $output_att_name=  $output_text_filter->( $output_att_name); }
  7112.  
  7113.              $tag .=   $output_att_name . '=' 
  7114.                      . $quote 
  7115.                      . $elt->att_xml_string( $att_name, $quote, $option->{escape_gt})
  7116.                      . $quote
  7117.                      ; 
  7118.            }
  7119.         } 
  7120.   
  7121.       $tag .= "\n" if($pretty==$NSGMLS);
  7122.  
  7123.       if( $elt->{empty} && !$elt->{extra_data_before_end_tag})
  7124.         { if( !$empty_tag_style)
  7125.             { $tag .= "/>";     }
  7126.           elsif( ($empty_tag_style eq $HTML) && $html_empty_elt{$XML::Twig::index2gi[$elt->{'gi'}]})
  7127.             { $tag .= " />";  }
  7128.           else #  $empty_tag_style eq $EXPAND
  7129.             { $tag .= "></" . $XML::Twig::index2gi[$elt->{'gi'}] .">";  }
  7130.         }
  7131.       else
  7132.         { $tag .= ">"; }
  7133.  
  7134.       if( ( (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 1) eq '#') && (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 9) ne '#default:') )) { $tag= ''; }
  7135.  
  7136.       unless( $pretty) { return $extra_data . $tag  }
  7137.  
  7138.       my $prefix='';
  7139.       my $return='';   # '' or \n is to be printed before the tag
  7140.       my $indent=0;    # number of indents before the tag
  7141.  
  7142.       if( $pretty==$RECORD1)
  7143.         { my $level= $elt->level;
  7144.           $return= "\n" if( $level < 2);
  7145.           $indent= 1 if( $level == 1);
  7146.         }
  7147.  
  7148.      elsif( $pretty==$RECORD2)
  7149.         { $return= "\n";
  7150.           $indent= $elt->level;
  7151.         }
  7152.  
  7153.       elsif( $pretty==$NICE)
  7154.         { my $parent= $elt->{parent};
  7155.           unless( !$parent || $parent->{contains_text}) 
  7156.             { $return= "\n"; }
  7157.           $elt->{contains_text}= 1 if( ($parent && $parent->{contains_text})
  7158.                                      || $elt->contains_text);
  7159.         }
  7160.  
  7161.       elsif( ($pretty==$INDENTED) || ($pretty==$INDENTEDC) || ($pretty==$WRAPPED))
  7162.         { my $parent= $elt->{parent};
  7163.           unless( !$parent || $parent->{contains_text}) 
  7164.             { $return= "\n"; 
  7165.               $indent= $elt->level; 
  7166.             }
  7167.           $elt->{contains_text}= 1 if( ($parent && $parent->{contains_text})
  7168.                                      || $elt->contains_text);
  7169.         }
  7170.  
  7171.       if( $return || $indent)
  7172.         { # check for elements in which spaces should be kept
  7173.           my $t= $elt->twig;
  7174.           return $extra_data . $tag if( $xml_space_preserve);
  7175.           if( $t && $t->{twig_keep_spaces_in})
  7176.             { foreach my $ancestor ($elt->ancestors)
  7177.                 { return $extra_data . $tag if( $t->{twig_keep_spaces_in}->{$XML::Twig::index2gi[$ancestor->{'gi'}]}) }
  7178.             }
  7179.         
  7180.           $prefix= $INDENT x $indent;
  7181.           if( $extra_data)
  7182.             { $extra_data=~ s{\s+$}{};
  7183.               $extra_data=~ s{^\s+}{};
  7184.               $extra_data= $prefix .  $extra_data . $return;
  7185.             }
  7186.         }
  7187.  
  7188.  
  7189.       return $return . $extra_data . $prefix . $tag;
  7190.     }
  7191.   
  7192.   sub end_tag
  7193.     { my $elt= shift;
  7194.       return  '' if(    ($elt->{gi}<$XML::Twig::SPECIAL_GI) 
  7195.                      || (($elt->{'empty'} || 0) && !$elt->{extra_data_before_end_tag})
  7196.                    );
  7197.       my $tag= "<";
  7198.       my $gi= $XML::Twig::index2gi[$elt->{'gi'}];
  7199.  
  7200.       if( my $map= $elt->{'att'}->{'#original_gi'}) { $gi= _restore_original_prefix( $map, $gi); }
  7201.       $gi=~ s{^#default:}{}; # remove default prefix
  7202.  
  7203.       if( $output_text_filter) { $gi= $output_text_filter->( $XML::Twig::index2gi[$elt->{'gi'}]); } 
  7204.       $tag .=  "/$gi>";
  7205.  
  7206.       $tag = ($elt->{extra_data_before_end_tag} || '') . $tag;
  7207.  
  7208.       if( ( (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 1) eq '#') && (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 9) ne '#default:') )) { $tag= ''; }
  7209.  
  7210.       return $tag unless $pretty;
  7211.  
  7212.       my $prefix='';
  7213.       my $return=0;    # 1 if a \n is to be printed before the tag
  7214.       my $indent=0;    # number of indents before the tag
  7215.  
  7216.       if( $pretty==$RECORD1)
  7217.         { $return= 1 if( $elt->level == 0);
  7218.         }
  7219.  
  7220.      elsif( $pretty==$RECORD2)
  7221.         { unless( $elt->contains_text)
  7222.             { $return= 1 ;
  7223.               $indent= $elt->level;
  7224.             }
  7225.         }
  7226.  
  7227.       elsif( $pretty==$NICE)
  7228.         { my $parent= $elt->{parent};
  7229.           if( (    ($parent && !$parent->{contains_text}) || !$parent )
  7230.             && ( !$elt->{contains_text}  
  7231.              && ($elt->{has_flushed_child} || $elt->_first_child())           
  7232.            )
  7233.          )
  7234.             { $return= 1; }
  7235.         }
  7236.  
  7237.       elsif( ($pretty==$INDENTED) || ($pretty==$WRAPPED) )
  7238.         { my $parent= $elt->{parent};
  7239.           if( (    ($parent && !$parent->{contains_text}) || !$parent )
  7240.             && ( !$elt->{contains_text}  
  7241.              && ($elt->{has_flushed_child} || $elt->_first_child())           
  7242.            )
  7243.          )
  7244.             { $return= 1; 
  7245.               $indent= $elt->level; 
  7246.             }
  7247.         }
  7248.  
  7249.       if( $return || $indent)
  7250.         { # check for elements in which spaces should be kept
  7251.           my $t= $elt->twig;
  7252.           return $tag if( $xml_space_preserve);
  7253.           if( $t && $t->{twig_keep_spaces_in})
  7254.             { foreach my $ancestor ($elt, $elt->ancestors)
  7255.                 { return $tag if( $t->{twig_keep_spaces_in}->{$XML::Twig::index2gi[$ancestor->{'gi'}]}) }
  7256.             }
  7257.       
  7258.           $prefix= "\n" if( $return);
  7259.           $prefix.= $INDENT x $indent;
  7260.     }
  7261.  
  7262.       # add a \n at the end of the document (after the root element)
  7263.       $tag .= "\n" unless( $elt->{parent});
  7264.   
  7265.       return $prefix . $tag;
  7266.     }
  7267.  
  7268.   sub _restore_original_prefix
  7269.     { my( $map, $name)= @_;
  7270.       my $prefix= _ns_prefix( $name);
  7271.       if( my $original_prefix= $map->{$prefix})
  7272.         { if( $original_prefix eq '#default')
  7273.             { $name=~ s{^$prefix:}{}; }
  7274.           else
  7275.             { $name=~ s{^$prefix(?=:)}{$original_prefix}; }
  7276.         }
  7277.       return $name;
  7278.     }
  7279.  
  7280.   # $elt is an element to print
  7281.   # $fh is an optional filehandle to print to
  7282.   # $pretty is an optional value, if true a \n is printed after the < of the
  7283.   # opening tag
  7284.   sub print
  7285.     { my $elt= shift;
  7286.   
  7287.       my $pretty;
  7288.       my $fh= _is_fh( $_[0]) ? shift : undef;
  7289.       my $old_select= defined $fh ? select $fh : undef;
  7290.       my $old_pretty= defined ($pretty= shift) ? set_pretty_print( $pretty) : undef;
  7291.  
  7292.       $xml_space_preserve= 1 if( ($elt->inherit_att( 'xml:space') || '') eq 'preserve');
  7293.  
  7294.       #$elt->_print;
  7295.       print $elt->sprint;
  7296.  
  7297.       $xml_space_preserve= 0;
  7298.     
  7299.       select $old_select if( defined $old_select);
  7300.       set_pretty_print( $old_pretty) if( defined $old_pretty);
  7301.     }
  7302.       
  7303.   
  7304.   # same as print but does not output the start tag if the element
  7305.   # is marked as flushed
  7306.   sub flush
  7307.     { my $elt= shift;
  7308.       $elt->twig->flush( @_);
  7309.     }
  7310.   
  7311.   sub _flush
  7312.     { my $elt= shift;
  7313.   
  7314.       my $pretty;
  7315.       my $fh=  _is_fh( $_[0]) ? shift : undef;
  7316.       my $old_select= defined $fh ? select $fh : undef;
  7317.       my $old_pretty= defined ($pretty= shift) ? set_pretty_print( $pretty) : undef;
  7318.  
  7319.       $xml_space_preserve= 1 if( ($elt->inherit_att( 'xml:space') || '') eq 'preserve');
  7320.  
  7321.       $elt->__flush();
  7322.  
  7323.       $xml_space_preserve= 0;
  7324.  
  7325.       select $old_select if( defined $old_select);
  7326.       set_pretty_print( $old_pretty) if( defined $old_pretty);
  7327.     }
  7328.  
  7329.   sub __flush
  7330.     { my $elt= shift;
  7331.   
  7332.       if( $elt->{gi} >= $XML::Twig::SPECIAL_GI)
  7333.         { my $preserve= ($elt->{'att'}->{'xml:space'} || '') eq 'preserve';
  7334.           $xml_space_preserve++ if $preserve;
  7335.           unless( $elt->_flushed)
  7336.             { print $elt->start_tag();
  7337.             }
  7338.       
  7339.           # flush the children
  7340.           my @children= $elt->children;
  7341.           foreach my $child (@children)
  7342.             { $child->_flush( $pretty); 
  7343.         }
  7344.           print $elt->end_tag;
  7345.           $xml_space_preserve-- if $preserve;
  7346.           # used for pretty printing
  7347.           if( my $parent= $elt->{parent}) { $parent->{has_flushed_child}= 1; }
  7348.         }
  7349.       else # text or special element
  7350.         { my $text;
  7351.           if( (exists $elt->{'pcdata'}))     { $text= $elt->pcdata_xml_string; 
  7352.                                      if( my $parent= $elt->{parent}) 
  7353.                                        { $parent->{contains_text}= 1; }
  7354.                                    }
  7355.           elsif( (exists $elt->{'cdata'}))   { $text= $elt->cdata_string;        
  7356.                                      if( my $parent= $elt->{parent}) 
  7357.                                        { $parent->{contains_text}= 1; }
  7358.                                    }
  7359.           elsif( (exists $elt->{'target'}))      { $text= $elt->pi_string;          }
  7360.           elsif( (exists $elt->{'comment'})) { $text= $elt->comment_string;     }
  7361.           elsif( (exists $elt->{'ent'}))     { $text= $elt->ent_string;         }
  7362.  
  7363.           print $output_filter ? $output_filter->( $text) : $text;
  7364.         }
  7365.     }
  7366.   
  7367.  
  7368.   sub xml_text
  7369.     { my $elt= shift;
  7370.       my $string='';
  7371.  
  7372.       if( $elt->{gi} >= $XML::Twig::SPECIAL_GI)
  7373.         { # sprint the children
  7374.           my $child= $elt->{first_child}||'';
  7375.           while( $child)
  7376.             { $string.= $child->xml_text;
  7377.               $child= $child->{next_sibling};
  7378.             }
  7379.         }
  7380.       elsif( (exists $elt->{'pcdata'}))  { $string .= $output_filter ?  $output_filter->($elt->pcdata_xml_string) 
  7381.                                                            : $elt->pcdata_xml_string; 
  7382.                                }
  7383.       elsif( (exists $elt->{'cdata'}))   { $string .= $output_filter ?  $output_filter->($elt->cdata_xml_string)  
  7384.                                                            : $elt->cdata_string;      
  7385.                                }
  7386.       elsif( (exists $elt->{'ent'}))     { $string .= $elt->ent_string; }
  7387.  
  7388.       return $string;
  7389.     }
  7390.  
  7391.  
  7392.   # same as print but except... it does not print but rather returns the string
  7393.   # if the second parameter is set then only the content is returned, not the
  7394.   # start and end tags of the element (but the tags of the included elements are
  7395.   # returned)
  7396.   sub sprint
  7397.     { my $elt= shift;
  7398.       my( $old_pretty, $old_empty_tag_style);
  7399.  
  7400.       if( $_[0] && UNIVERSAL::isa( $_[0], 'HASH'))
  7401.         { my %args= XML::Twig::_normalize_args( %{shift()}); 
  7402.           if( defined $args{PrettyPrint}) { $old_pretty= set_pretty_print( $args{PrettyPrint}); }
  7403.            if( defined $args{EmptyTags})  { $old_empty_tag_style= set_empty_tag_style( $args{EmptyTags}); }
  7404.         }
  7405.  
  7406.       $xml_space_preserve= 1 if( ($elt->inherit_att( 'xml:space') || '') eq 'preserve');
  7407.       my $sprint= $output_filter ? $output_filter->( $elt->_sprint( @_)) : $elt->_sprint( @_);
  7408.       if( $pretty== $WRAPPED && !$xml_space_preserve)
  7409.         { $sprint= _wrap_text( $sprint); }
  7410.       $xml_space_preserve= 0;
  7411.  
  7412.  
  7413.       set_pretty_print( $old_pretty) if( defined $old_pretty); 
  7414.       set_empty_tag_style( $old_empty_tag_style) if( defined $old_empty_tag_style); 
  7415.  
  7416.       return $sprint;
  7417.     }
  7418.   
  7419.   sub _wrap_text
  7420.     { my( $string)= @_;
  7421.       my $wrapped;
  7422.       foreach my $line (split /\n/, $string)
  7423.         { my( $initial_indent)= $line=~ m{^(\s*)};
  7424.           my $wrapped_line= Text::Wrap::wrap(  '',  $initial_indent . $INDENT, $line) . "\n";
  7425.           
  7426.           # fix glitch with Text::wrap when the first line is long and does not include spaces
  7427.           # the first line ends up being too short by 2 chars, but we'll have to live with it!
  7428.           $wrapped_line=~ s{^ +\n  }{}s; # this prefix needs to be removed
  7429.       
  7430.           $wrapped .= $wrapped_line;
  7431.         }
  7432.      
  7433.       return $wrapped;
  7434.     }
  7435.       
  7436.   
  7437.   sub _sprint
  7438.     { my $elt= shift;
  7439.       my $no_tag= shift || 0;
  7440.       # in case there's some comments or PI's piggybacking
  7441.       my $string='';
  7442.  
  7443.       if( $elt->{gi} >= $XML::Twig::SPECIAL_GI)
  7444.         {
  7445.           my $preserve= ($elt->{'att'}->{'xml:space'} || '') eq 'preserve';
  7446.           $xml_space_preserve++ if $preserve;
  7447.  
  7448.           $string.= $elt->start_tag unless( $no_tag);
  7449.       
  7450.           # sprint the children
  7451.           my $child= $elt->{first_child};
  7452.           while( $child)
  7453.             { $string.= $child->_sprint;
  7454.               $child= $child->{next_sibling};
  7455.             }
  7456.           $string.= $elt->end_tag unless( $no_tag);
  7457.           $xml_space_preserve-- if $preserve;
  7458.         }
  7459.       else
  7460.         { $string .= $elt->{extra_data} || '';
  7461.              if( (exists $elt->{'pcdata'}))  { $string .= $elt->pcdata_xml_string; }
  7462.           elsif( (exists $elt->{'cdata'}))   { $string .= $elt->cdata_string;      }
  7463.           elsif( (exists $elt->{'target'}))      { $string .= $elt->pi_string;
  7464.                                      if( ($pretty >= $INDENTED) && !$elt->{parent}->{contains_text}) { $string .= "\n"; }
  7465.                                    }
  7466.           elsif( (exists $elt->{'comment'})) { $string .= $elt->comment_string;    
  7467.                                      if( ($pretty >= $INDENTED) && !$elt->{parent}->{contains_text}) { $string .= "\n"; }
  7468.                                    }
  7469.           elsif( (exists $elt->{'ent'}))     { $string .= $elt->ent_string;        }
  7470.         }
  7471.  
  7472.       return $string;
  7473.     }
  7474.  
  7475.   # just a shortcut to $elt->sprint( 1)
  7476.   sub xml_string
  7477.     { $_[0]->sprint( 1); }
  7478.  
  7479.   sub pcdata_xml_string 
  7480.     { my $elt= shift;
  7481.       if( defined( my $string= $elt->{pcdata}) )
  7482.         { 
  7483.           if( $elt->{extra_data_in_pcdata})
  7484.             { _gen_mark( $string); # used by _(un)?protect_extra_data
  7485.               foreach my $data (reverse @{$elt->{extra_data_in_pcdata}})
  7486.                 { my $substr= substr( $string, $data->{offset});
  7487.                   if( $keep_encoding || $elt->{asis})
  7488.                     { substr( $string, $data->{offset}, 0, $data->{text}); }
  7489.                   else
  7490.                     { substr( $string, $data->{offset}, 0, _protect_extra_data( $data->{text})); }
  7491.                 }
  7492.               unless( $keep_encoding || $elt->{asis})
  7493.                 { $string=~ s/([&<])/$XML::Twig::base_ent{$1}/g ;
  7494.                   $string=~ s{\Q]]>}{]]>}g;
  7495.                   _unprotect_extra_data( $string);
  7496.                 }
  7497.             }
  7498.           else
  7499.             { $string=~ s/([&<])/$XML::Twig::base_ent{$1}/g unless( $keep_encoding || $elt->{asis});  
  7500.               $string=~ s{\Q]]>}{]]>}g;
  7501.             }
  7502.           return $output_text_filter ? $output_text_filter->( $string) : $string;
  7503.         }
  7504.       else
  7505.         { return ''; }
  7506.     }
  7507.  
  7508.   { my $mark;
  7509.     my( %char2ent, %ent2char);
  7510.     BEGIN
  7511.       { %char2ent= ( '<' => 'lt', '&' => 'amp');
  7512.         %ent2char= ( 'lt' => '<', 'amp' => '&');
  7513.       }
  7514.  
  7515.     # generate a unique mark (a string) not found in the string, 
  7516.     # used to mark < and & in the extra data
  7517.     sub _gen_mark
  7518.       { $mark="AAAA";
  7519.         $mark++ while( index( $_[0], $mark) > -1);
  7520.         return $mark;
  7521.       }
  7522.       
  7523.     sub _protect_extra_data
  7524.       { my( $extra_data)= @_;
  7525.         $extra_data=~ s{([&<])}{:$mark:$char2ent{$1}:}g;
  7526.         return $extra_data;
  7527.       }
  7528.  
  7529.     sub _unprotect_extra_data
  7530.       { $_[0]=~ s{:$mark:(\w+):}{$ent2char{$1}}g; }
  7531.  
  7532.   } 
  7533.   
  7534.   sub cdata_string
  7535.     { my $cdata= $_[0]->{cdata};
  7536.       unless( defined $cdata) { return ''; }
  7537.       if( $remove_cdata)
  7538.         { $cdata=~ s/([&<])/$XML::Twig::base_ent{$1}/g; }
  7539.       else
  7540.         { $cdata= CDATA_START . $cdata . CDATA_END; }
  7541.       return $cdata;
  7542.    }
  7543.  
  7544.   sub att_xml_string 
  7545.     { my $elt= shift;
  7546.       my $att= shift;
  7547.       if( defined (my $string= $elt->{att}->{$att}))
  7548.         { return _att_xml_string( $string, @_); }
  7549.       else
  7550.         { return ''; }
  7551.     }
  7552.     
  7553.   # escaped xml string for an attribute value
  7554.   sub _att_xml_string 
  7555.     { my( $string, $quote, $escape_gt)= @_;
  7556.       unless( $keep_encoding)
  7557.         { my $replace= "$quote<";
  7558.           $replace .= '>' if( $escape_gt);
  7559.           
  7560.           if( $do_not_escape_amp_in_atts)
  7561.             { $string=~ s{([$replace])}{$XML::Twig::base_ent{$1}}g; 
  7562.               $string=~ s{&(?!(\w+|#\d+|[xX][0-9a-fA-F]+);)}{&}g; # dodgy: escape & that do not start an entity
  7563.             }
  7564.           else
  7565.             { $replace.= "&";
  7566.               $string=~ s{([$replace])}{$XML::Twig::base_ent{$1}}g; 
  7567.               unless( $escape_gt) { $string=~ s{\Q]]>}{]]>}g; }
  7568.             }
  7569.         }
  7570.       return $output_text_filter ? $output_text_filter->( $string) : $string;
  7571.     }
  7572.  
  7573.   sub ent_string 
  7574.     { my $ent= shift;
  7575.       my $ent_text= $ent->{ent};
  7576.       my( $t, $el, $ent_string);
  7577.       if(    $expand_external_entities
  7578.           && ($t= $ent->twig) 
  7579.           && ($el= $t->entity_list)
  7580.           && ($ent_string= $el->{entities}->{$ent->ent_name}->{val})
  7581.         )
  7582.        { return $ent_string; }
  7583.   
  7584.        return $ent_text; 
  7585.     }
  7586.  
  7587.   # returns just the text, no tags, for an element
  7588.   sub text
  7589.     { my $elt= shift;
  7590.       my $string;
  7591.   
  7592.       if( (exists $elt->{'pcdata'}))     { return  $elt->{pcdata};   }
  7593.       elsif( (exists $elt->{'cdata'}))   { return  $elt->{cdata};    }
  7594.       elsif( (exists $elt->{'target'}))      { return  $elt->pi_string;}
  7595.       elsif( (exists $elt->{'comment'})) { return  $elt->{comment};  }
  7596.       elsif( (exists $elt->{'ent'}))     { return  $elt->{ent} ;     }
  7597.   
  7598.       my $child= $elt->{first_child} ||'';
  7599.       while( $child)
  7600.         { my $child_text= $child->text;
  7601.           $string.= defined( $child_text) ? $child_text : '';
  7602.           $child= $child->{next_sibling};
  7603.         }
  7604.       unless( defined $string) { $string=''; }
  7605.   
  7606.       return $output_text_filter ? $output_text_filter->( $string) : $string;
  7607.     }
  7608.  
  7609.   sub trimmed_text
  7610.     { my $elt= shift;
  7611.       my $text= $elt->text;
  7612.       $text=~ s{\s+}{ }sg;
  7613.       $text=~ s{^\s*}{};
  7614.       $text=~ s{\s*$}{};
  7615.       return $text;
  7616.     }
  7617.  
  7618.   sub trim
  7619.     { my( $elt)= @_;
  7620.       my $pcdata= $elt->first_descendant( '#TEXT');
  7621.       (my $pcdata_text= $pcdata->text)=~ s{^\s+}{}s;
  7622.       $pcdata->set_text( $pcdata_text);
  7623.       $pcdata= $elt->last_descendant( '#TEXT');
  7624.       ($pcdata_text= $pcdata->text)=~ s{\s+$}{};
  7625.       $pcdata->set_text( $pcdata_text);
  7626.       foreach $pcdata ($elt->descendants( '#TEXT'))
  7627.         { ($pcdata_text= $pcdata->text)=~ s{\s+}{ }g;
  7628.           $pcdata->set_text( $pcdata_text);
  7629.         }
  7630.       return $elt;
  7631.     }
  7632.   
  7633.  
  7634.   # remove cdata sections (turns them into regular pcdata) in an element 
  7635.   sub remove_cdata 
  7636.     { my $elt= shift;
  7637.       foreach my $cdata ($elt->descendants_or_self( CDATA))
  7638.         { if( $keep_encoding)
  7639.             { my $data= $cdata->{cdata};
  7640.               $data=~ s{([&<"'])}{$XML::Twig::base_ent{$1}}g;
  7641.               $cdata->set_pcdata( $data);
  7642.             }
  7643.           else
  7644.             { $cdata->set_pcdata( $cdata->{cdata}); }
  7645.           $cdata->set_gi( PCDATA);
  7646.           undef $cdata->{cdata};
  7647.         }
  7648.     }
  7649.  
  7650. sub _is_private      { return _is_private_name( $_[0]->gi); }
  7651. sub _is_private_name { return $_[0]=~ m{^#(?!default:)};                }
  7652.  
  7653.  
  7654. } # end of block containing package globals ($pretty_print, $quotes, keep_encoding...)
  7655.  
  7656.  
  7657. # SAX export methods
  7658. sub toSAX1
  7659.   { _toSAX(@_, \&_start_tag_data_SAX1, \&_end_tag_data_SAX1); }
  7660.  
  7661. sub toSAX2
  7662.   { _toSAX(@_, \&_start_tag_data_SAX2, \&_end_tag_data_SAX2); }
  7663.  
  7664. sub _toSAX
  7665.   { my( $elt, $handler, $start_tag_data, $end_tag_data)= @_;
  7666.     if( $elt->{gi} >= $XML::Twig::SPECIAL_GI)
  7667.       { my $data= $start_tag_data->( $elt);
  7668.         _start_prefix_mapping( $elt, $handler, $data);
  7669.         if( $data && (my $start_element = $handler->can( 'start_element')))
  7670.           { $start_element->( $handler, $data) unless( $elt->_flushed); }
  7671.       
  7672.         foreach my $child ($elt->children)
  7673.           { $child->_toSAX( $handler, $start_tag_data, $end_tag_data); }
  7674.  
  7675.         if( (my $data= $end_tag_data->( $elt)) && (my $end_element = $handler->can( 'end_element')) )
  7676.           { $end_element->( $handler, $data); }
  7677.         _end_prefix_mapping( $elt, $handler);
  7678.       }
  7679.     else # text or special element
  7680.       { if( (exists $elt->{'pcdata'}) && (my $characters= $handler->can( 'characters')))
  7681.           { $characters->( $handler, { Data => $elt->{pcdata} });  }
  7682.         elsif( (exists $elt->{'cdata'}))  
  7683.           { if( my $start_cdata= $handler->can( 'start_cdata'))
  7684.               { $start_cdata->( $handler); }
  7685.             if( my $characters= $handler->can( 'characters'))
  7686.               { $characters->( $handler, {Data => $elt->{cdata} });  }
  7687.             if( my $end_cdata= $handler->can( 'end_cdata'))
  7688.               { $end_cdata->( $handler); }
  7689.           }
  7690.         elsif( ((exists $elt->{'target'}))  && (my $pi= $handler->can( 'processing_instruction')))
  7691.           { $pi->( $handler, { Target =>$elt->{target}, Data => $elt->{data} });  }
  7692.         elsif( ((exists $elt->{'comment'}))  && (my $comment= $handler->can( 'comment')))
  7693.           { $comment->( $handler, { Data => $elt->{comment} });  }
  7694.         elsif( ((exists $elt->{'ent'})))
  7695.           { 
  7696.             if( my $se=   $handler->can( 'skipped_entity'))
  7697.               { $se->( $handler, { Name => $elt->ent_name });  }
  7698.             elsif( my $characters= $handler->can( 'characters'))
  7699.               { if( defined $elt->ent_string)
  7700.                   { $characters->( $handler, {Data => $elt->ent_string});  }
  7701.                 else
  7702.                   { $characters->( $handler, {Data => $elt->ent_name});  }
  7703.               }
  7704.           }
  7705.       
  7706.       }
  7707.   }
  7708.   
  7709. sub _start_tag_data_SAX1
  7710.   { my( $elt)= @_;
  7711.     my $name= $XML::Twig::index2gi[$elt->{'gi'}];
  7712.     return if( ( (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 1) eq '#') && (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 9) ne '#default:') ));
  7713.     my $attributes={};
  7714.     my $atts= $elt->atts;
  7715.     while( my( $att, $value)= each %$atts)
  7716.       { $attributes->{$att}= $value unless( ( (substr( $att, 0, 1) eq '#') && (substr( $att, 0, 9) ne '#default:') )); }
  7717.     my $data= { Name => $name, Attributes => $attributes};
  7718.     return $data;
  7719.   }
  7720.  
  7721. sub _end_tag_data_SAX1
  7722.   { my( $elt)= @_;
  7723.     return if( ( (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 1) eq '#') && (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 9) ne '#default:') ));
  7724.     return  { Name => $XML::Twig::index2gi[$elt->{'gi'}] };
  7725.   } 
  7726.   
  7727. sub _start_tag_data_SAX2
  7728.   { my( $elt)= @_;
  7729.     my $data={};
  7730.     
  7731.     my $name= $XML::Twig::index2gi[$elt->{'gi'}];
  7732.     return if( ( (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 1) eq '#') && (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 9) ne '#default:') ));
  7733.     $data->{Name}         = $name;
  7734.     $data->{Prefix}       = $elt->ns_prefix; 
  7735.     $data->{LocalName}    = $elt->local_name;
  7736.     $data->{NamespaceURI} = $elt->namespace;
  7737.  
  7738.     # save a copy of the data so we can re-use it for the end tag
  7739.     my %sax2_data= %$data;
  7740.     $elt->{twig_elt_SAX2_data}= \%sax2_data;
  7741.    
  7742.     # add the attributes
  7743.     $data->{Attributes}= $elt->_atts_to_SAX2;
  7744.  
  7745.     return $data;
  7746.   }
  7747.  
  7748. sub _atts_to_SAX2
  7749.   { my $elt= shift;
  7750.     my $SAX2_atts= {};
  7751.     foreach my $att (keys %{$elt->atts})
  7752.       { 
  7753.         next if( ( (substr( $att, 0, 1) eq '#') && (substr( $att, 0, 9) ne '#default:') ));
  7754.         my $SAX2_att={};
  7755.         $SAX2_att->{Name}         = $att;
  7756.         $SAX2_att->{Prefix}       = _ns_prefix( $att); 
  7757.         $SAX2_att->{LocalName}    = _local_name( $att);
  7758.         $SAX2_att->{NamespaceURI} = $elt->namespace( $SAX2_att->{Prefix});
  7759.         $SAX2_att->{Value}        = $elt->{'att'}->{$att};
  7760.         my $SAX2_att_name= "{$SAX2_att->{NamespaceURI}}$SAX2_att->{LocalName}";
  7761.  
  7762.         $SAX2_atts->{$SAX2_att_name}= $SAX2_att;
  7763.       }
  7764.     return $SAX2_atts;
  7765.   }
  7766.  
  7767. sub _start_prefix_mapping
  7768.   { my( $elt, $handler, $data)= @_;
  7769.     if( my $start_prefix_mapping= $handler->can( 'start_prefix_mapping')
  7770.         and my @new_prefix_mappings= grep { /^\{[^}]*\}xmlns/ || /^\{$XMLNS_URI\}/ } keys %{$data->{Attributes}}
  7771.       )
  7772.       { foreach my $prefix (@new_prefix_mappings)
  7773.           { my $prefix_string= $data->{Attributes}->{$prefix}->{LocalName};
  7774.             if( $prefix_string eq 'xmlns') { $prefix_string=''; }
  7775.             my $prefix_data=
  7776.               {  Prefix       => $prefix_string,
  7777.                  NamespaceURI => $data->{Attributes}->{$prefix}->{Value}
  7778.               };
  7779.             $start_prefix_mapping->( $handler, $prefix_data);
  7780.             $elt->{twig_end_prefix_mapping} ||= [];
  7781.             push @{$elt->{twig_end_prefix_mapping}}, $prefix_string;
  7782.           }
  7783.       }
  7784.   }
  7785.  
  7786. sub _end_prefix_mapping
  7787.   { my( $elt, $handler)= @_;
  7788.     if( my $end_prefix_mapping= $handler->can( 'end_prefix_mapping'))
  7789.       { foreach my $prefix (@{$elt->{twig_end_prefix_mapping}})
  7790.           { $end_prefix_mapping->( $handler, { Prefix => $prefix} ); }
  7791.       }
  7792.   }
  7793.              
  7794. sub _end_tag_data_SAX2
  7795.   { my( $elt)= @_;
  7796.     return if( ( (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 1) eq '#') && (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 9) ne '#default:') ));
  7797.     return $elt->{twig_elt_SAX2_data};
  7798.   } 
  7799.  
  7800.  
  7801.  
  7802. #start-extract twig_node
  7803. sub contains_text
  7804.   { my $elt= shift;
  7805.     my $child= $elt->{first_child};
  7806.     while ($child)
  7807.       { return 1 if( $child->is_text || (exists $child->{'ent'})); 
  7808.         $child= $child->{next_sibling};
  7809.       }
  7810.     return 0;
  7811.   }
  7812.  
  7813. #end-extract twig_node
  7814.  
  7815. # creates a single pcdata element containing the text as child of the element
  7816. # options: 
  7817. #   - force_pcdata: when set to a true value forces the text to be in a #PCDATA
  7818. #                   even if the original element was a #CDATA
  7819. sub set_text
  7820.   { my( $elt, $string, %option)= @_;
  7821.  
  7822.     if( $XML::Twig::index2gi[$elt->{'gi'}] eq PCDATA) 
  7823.       { return $elt->set_pcdata( $string); }
  7824.     elsif( $XML::Twig::index2gi[$elt->{'gi'}] eq CDATA)  
  7825.       { if( $option{force_pcdata})
  7826.           { $elt->set_gi( PCDATA);
  7827.             $elt->_set_cdata('');
  7828.             return $elt->set_pcdata( $string);
  7829.           }
  7830.         else
  7831.           { return $elt->_set_cdata( $string); }
  7832.       }
  7833.     elsif( $elt->contains_a_single( PCDATA) )
  7834.       { # optimized so we have a slight chance of not loosing embedded comments and pi's
  7835.         return $elt->{first_child}->set_pcdata( $string);
  7836.       }
  7837.  
  7838.     foreach my $child (@{[$elt->children]})
  7839.       { $child->delete; }
  7840.  
  7841.     my $pcdata= $elt->new( PCDATA, $string);
  7842.     $pcdata->paste( $elt);
  7843.  
  7844.     delete $elt->{empty};
  7845.  
  7846.     return $elt;
  7847.   }
  7848.  
  7849. # set the content of an element from a list of strings and elements
  7850. sub set_content
  7851.   { my $elt= shift;
  7852.  
  7853.     return $elt unless defined $_[0];
  7854.  
  7855.     # attributes can be given as a hash (passed by ref)
  7856.     if( ref $_[0] eq 'HASH')
  7857.       { my $atts= shift;
  7858.         $elt->del_atts; # usually useless but better safe than sorry
  7859.         $elt->set_atts( $atts);
  7860.         return  $elt unless defined $_[0];
  7861.       }
  7862.  
  7863.     # check next argument for #EMPTY
  7864.     if( !(ref $_[0]) && ($_[0] eq EMPTY) ) 
  7865.       { $elt->{empty}= 1; return $elt; }
  7866.  
  7867.     # case where we really want to do a set_text, the element is '#PCDATA'
  7868.     # or contains a single PCDATA and we only want to add text in it
  7869.     if( ($XML::Twig::index2gi[$elt->{'gi'}] eq PCDATA || $elt->contains_a_single( PCDATA)) 
  7870.         && ($#_ == 0) && !( ref $_[0]))
  7871.       { $elt->set_text( $_[0]);
  7872.         return $elt;
  7873.       }
  7874.     elsif( ($XML::Twig::index2gi[$elt->{'gi'}] eq CDATA) && ($#_ == 0) && !( ref $_[0]))
  7875.       { $elt->_set_cdata( $_[0]);
  7876.         return $elt;
  7877.       }
  7878.  
  7879.     # delete the children
  7880.     # WARNING: potential problem here if the children are used
  7881.     # somewhere else (where?). Will be solved when I use weak refs
  7882.     foreach my $child (@{[$elt->children]})
  7883.       { $child->delete; }
  7884.  
  7885.     foreach my $child (@_)
  7886.       { if( isa( $child, 'XML::Twig::Elt'))
  7887.           { # argument is an element
  7888.             $child->paste( 'last_child', $elt);
  7889.           }
  7890.         else
  7891.           { # argument is a string
  7892.             if( (my $pcdata= $elt->{last_child}) && $elt->{last_child}->is_pcdata)
  7893.               { # previous child is also pcdata: just concatenate
  7894.                 $pcdata->set_pcdata( $pcdata->{pcdata} . $child) 
  7895.               }
  7896.             else
  7897.               { # previous child is not a string: creat a new pcdata element
  7898.                 $pcdata= $elt->new( PCDATA, $child);
  7899.                 $pcdata->paste( 'last_child', $elt);  
  7900.               }
  7901.           }
  7902.       }
  7903.  
  7904.     delete $elt->{empty};
  7905.  
  7906.     return $elt;
  7907.   }
  7908.  
  7909. # inserts an element (whose gi is given) as child of the element
  7910. # all children of the element are now children of the new element
  7911. # returns the new element
  7912. sub insert
  7913.   { my ($elt, @args)= @_;
  7914.     # first cut the children
  7915.     my @children= $elt->children;
  7916.     foreach my $child (@children)
  7917.       { $child->cut; }
  7918.     # insert elements
  7919.     while( my $gi= shift @args)
  7920.       { my $new_elt= $elt->new( $gi);
  7921.         # add attributes if needed
  7922.         if( defined( $args[0]) && ( isa( $args[0], 'HASH')) )
  7923.           { $new_elt->set_atts( shift @args); }
  7924.         # paste the element
  7925.         $new_elt->paste( $elt);
  7926.         delete $elt->{empty};
  7927.         $elt= $new_elt;
  7928.       }
  7929.     # paste back the children
  7930.     foreach my $child (@children)
  7931.       { $child->paste( 'last_child', $elt); }
  7932.     return $elt;
  7933.   }
  7934.  
  7935. # insert a new element 
  7936. # $elt->insert_new_element( $opt_position, $gi, $opt_atts_hash, @opt_content); 
  7937. # the element is created with the same syntax as new
  7938. # position is the same as in paste, first_child by default
  7939. sub insert_new_elt
  7940.   { my $elt= shift;
  7941.     my $position= $_[0];
  7942.     if(     ($position eq 'before') || ($position eq 'after')
  7943.          || ($position eq 'first_child') || ($position eq 'last_child'))
  7944.       { shift; }
  7945.     else
  7946.       { $position= 'first_child'; }
  7947.  
  7948.     my $new_elt= $elt->new( @_);
  7949.     $new_elt->paste( $position, $elt);
  7950.  
  7951.     #if( defined $new_elt->{'att'}->{$ID}) { $new_elt->set_id( $new_elt->{'att'}->{$ID}); }
  7952.     
  7953.     return $new_elt;
  7954.   }
  7955.  
  7956. # wraps an element in elements which gi's are given as arguments
  7957. # $elt->wrap_in( 'td', 'tr', 'table') wraps the element as a single
  7958. # cell in a table for example
  7959. # returns the new element
  7960. sub wrap_in
  7961.   { my $elt= shift;
  7962.     while( my $gi = shift @_)
  7963.       { my $new_elt = $elt->new( $gi);
  7964.         if( $elt->{twig_current})
  7965.           { my $t= $elt->twig;
  7966.             $t->{twig_current}= $new_elt;
  7967.             delete $elt->{'twig_current'};
  7968.             $new_elt->{'twig_current'}=1;
  7969.           }
  7970.  
  7971.         if( my $parent= $elt->{parent})
  7972.           { $new_elt->set_parent( $parent); 
  7973.             $parent->{first_child}=  $new_elt if( $parent->{first_child} == $elt);
  7974.             $parent->set_last_child( $new_elt)  if( $parent->{last_child} == $elt);
  7975.           }
  7976.         else
  7977.           { # wrapping the root
  7978.             my $twig= $elt->twig;
  7979.             if( $twig && $twig->root && ($twig->root eq $elt) )
  7980.               { $twig->{twig_root}= $new_elt; }
  7981.           }
  7982.  
  7983.         if( my $prev_sibling= $elt->{prev_sibling})
  7984.           { $new_elt->set_prev_sibling( $prev_sibling);
  7985.             $prev_sibling->{next_sibling}=  $new_elt;
  7986.           }
  7987.  
  7988.         if( my $next_sibling= $elt->{next_sibling})
  7989.           { $new_elt->{next_sibling}=  $next_sibling;
  7990.             $next_sibling->set_prev_sibling( $new_elt);
  7991.           }
  7992.         $new_elt->{first_child}=  $elt;
  7993.         $new_elt->set_last_child( $elt);
  7994.  
  7995.         $elt->set_parent( $new_elt);
  7996.         $elt->set_prev_sibling( undef);
  7997.         $elt->{next_sibling}=  undef;
  7998.  
  7999.         # add the attributes if the next argument is a hash ref
  8000.         if( defined( $_[0]) && (isa( $_[0], 'HASH')) )
  8001.           { $new_elt->set_atts( shift @_); }
  8002.  
  8003.         $elt= $new_elt;
  8004.       }
  8005.       
  8006.     return $elt;
  8007.   }
  8008.  
  8009. sub replace
  8010.   { my( $elt, $ref)= @_;
  8011.     if( my $parent= $ref->{parent})
  8012.       { $elt->set_parent( $parent);
  8013.         $parent->{first_child}=  $elt if( $parent->{first_child} == $ref);
  8014.         $parent->set_last_child( $elt)  if( $parent->{last_child} == $ref);
  8015.       }
  8016.     if( my $prev_sibling= $ref->{prev_sibling})
  8017.       { $elt->set_prev_sibling( $prev_sibling);
  8018.         $prev_sibling->{next_sibling}=  $elt;
  8019.       }
  8020.     if( my $next_sibling= $ref->{next_sibling})
  8021.       { $elt->{next_sibling}=  $next_sibling;
  8022.         $next_sibling->set_prev_sibling( $elt);
  8023.       }
  8024.    
  8025.     $ref->set_parent( undef);
  8026.     $ref->set_prev_sibling( undef);
  8027.     $ref->{next_sibling}=  undef;
  8028.     return $ref;
  8029.   }
  8030.  
  8031. sub replace_with
  8032.   { my $ref= shift;
  8033.     my $elt= shift;
  8034.     $elt->replace( $ref);
  8035.     foreach my $new_elt (reverse @_)
  8036.       { $new_elt->paste( after => $elt); }
  8037.     return $elt;
  8038.   }
  8039.  
  8040.  
  8041. #start-extract twig_node
  8042. # move an element, same syntax as paste, except the element is first cut
  8043. sub move
  8044.   { my $elt= shift;
  8045.     $elt->cut;
  8046.     $elt->paste( @_);
  8047.     return $elt;
  8048.   }
  8049. #end-extract twig_node
  8050.  
  8051.  
  8052. # adds a prefix to an element, creating a pcdata child if needed
  8053. sub prefix
  8054.   { my ($elt, $prefix, $option)= @_;
  8055.     my $asis= ($option && ($option eq 'asis')) ? 1 : 0;
  8056.     if( (exists $elt->{'pcdata'}) 
  8057.         && (($asis && $elt->{asis}) || (!$asis && ! $elt->{asis}))
  8058.       )
  8059.       { $elt->set_pcdata( $prefix . $elt->{pcdata}); }
  8060.     elsif( $elt->{first_child} && $elt->{first_child}->is_pcdata
  8061.         && (   ($asis && $elt->{first_child}->{asis}) 
  8062.             || (!$asis && ! $elt->{first_child}->{asis}))
  8063.          )
  8064.       { 
  8065.         $elt->{first_child}->set_pcdata( $prefix . $elt->{first_child}->pcdata); 
  8066.       }
  8067.     else
  8068.       { my $new_elt= $elt->new( PCDATA, $prefix);
  8069.         $new_elt->paste( $elt);
  8070.         $new_elt->set_asis if( $asis);
  8071.       }
  8072.     return $elt;
  8073.   }
  8074.  
  8075. # adds a suffix to an element, creating a pcdata child if needed
  8076. sub suffix
  8077.   { my ($elt, $suffix, $option)= @_;
  8078.     my $asis= ($option && ($option eq 'asis')) ? 1 : 0;
  8079.     if( (exists $elt->{'pcdata'})
  8080.         && (($asis && $elt->{asis}) || (!$asis && ! $elt->{asis}))
  8081.       )
  8082.       { $elt->set_pcdata( $elt->{pcdata} . $suffix); }
  8083.     elsif( $elt->{last_child} && $elt->{last_child}->is_pcdata
  8084.         && (   ($asis && $elt->{last_child}->{asis}) 
  8085.             || (!$asis && ! $elt->{last_child}->{asis}))
  8086.          )
  8087.       { $elt->{last_child}->set_pcdata( $elt->{last_child}->pcdata . $suffix); }
  8088.     else
  8089.       { my $new_elt= $elt->new( PCDATA, $suffix);
  8090.         $new_elt->paste( 'last_child', $elt);
  8091.         $new_elt->set_asis if( $asis);
  8092.       }
  8093.     return $elt;
  8094.   }
  8095.  
  8096. #start-extract twig_node
  8097. # create a path to an element ('/root/.../gi)
  8098. sub path
  8099.   { my $elt= shift;
  8100.     my @context= ( $elt, $elt->ancestors);
  8101.     return "/" . join( "/", reverse map {$_->gi} @context);
  8102.   }
  8103.  
  8104. sub xpath
  8105.   { my $elt= shift;
  8106.     my $xpath;
  8107.     foreach my $ancestor (reverse $elt->ancestors_or_self)
  8108.       { my $gi= $XML::Twig::index2gi[$ancestor->{'gi'}];
  8109.         $xpath.= "/$gi";
  8110.         my $index= $ancestor->prev_siblings( $gi) + 1;
  8111.         unless( ($index == 1) && !$ancestor->next_sibling( $gi))
  8112.           { $xpath.= "[$index]"; }
  8113.       }
  8114.     return $xpath;
  8115.   }
  8116.  
  8117. # methods used mainly by wrap_children
  8118.  
  8119. # return a string with the 
  8120. # for an element <foo><elt att="val">...</elt><elt2/><elt>...</elt></foo>
  8121. # returns '<elt att="val"><elt2><elt>'
  8122. sub _stringify_struct
  8123.   { my( $elt, %opt)= @_;
  8124.     my $string='';
  8125.     my $pretty_print= set_pretty_print( 'none');
  8126.     foreach my $child ($elt->children)
  8127.       { $child->add_id; $string .= $child->start_tag( { escape_gt => 1 }) ||''; }
  8128.     set_pretty_print( $pretty_print);
  8129.     return $string;
  8130.   }
  8131.  
  8132. # wrap a series of elements in a new one
  8133. sub _wrap_range
  8134.   { my $elt= shift;
  8135.     my $gi= shift;
  8136.     my $atts= isa( $_[0], 'HASH') ? shift : undef;
  8137.     my $range= shift; # the string with the tags to wrap
  8138.  
  8139.     my $t= $elt->twig;
  8140.  
  8141.     # get the tags to wrap
  8142.     my @to_wrap;
  8143.     while( $range=~ m{<\w+\s+[^>]*id=("[^"]*"|'[^']*')[^>]*>}g)
  8144.       { push @to_wrap, $t->elt_id( substr( $1, 1, -1)); }
  8145.  
  8146.     return '' unless @to_wrap;
  8147.     
  8148.     my $to_wrap= shift @to_wrap;
  8149.     my %atts= %$atts;
  8150.     my $new_elt= $to_wrap->wrap_in( $gi, \%atts);
  8151.     $_->move( last_child => $new_elt) foreach (@to_wrap);
  8152.  
  8153.     return '';
  8154.   }
  8155.     
  8156. # wrap children matching a regexp in a new element
  8157. sub wrap_children
  8158.   { my( $elt, $regexp, $gi, $atts)= @_;
  8159.  
  8160.     $atts ||={};
  8161.  
  8162.     my $elt_as_string= $elt->_stringify_struct; # stringify the elt structure
  8163.     $regexp=~ s{(<[^>]*>)}{_match_expr( $1)}eg; # in the regexp, replace gi's by the proper regexp 
  8164.     $elt_as_string=~ s{($regexp)}{$elt->_wrap_range( $gi, $atts, $1)}eg; # then do the actual replace
  8165.   
  8166.     return $elt; 
  8167.   }
  8168.  
  8169. sub _match_expr
  8170.   { my $tag= shift;
  8171.     my( $gi, %atts)= XML::Twig::_parse_start_tag( $tag);
  8172.     return _match_tag( $gi, %atts);
  8173.   }
  8174.  
  8175.  
  8176. sub _match_tag
  8177.   { my( $elt, %atts)= @_;
  8178.     my $string= "<$elt\\b";
  8179.     foreach my $key (sort keys %atts)
  8180.       { my $val= qq{\Q$atts{$key}\E};
  8181.         $string.= qq{[^>]*$key=(?:"$val"|'$val')};
  8182.       }
  8183.     $string.=  qq{[^>]*>};
  8184.     return "(?:$string)";
  8185.   }
  8186.  
  8187. sub field_to_att
  8188.   { my( $elt, $cond, $att)= @_;
  8189.     $att ||= $cond;
  8190.     my $child= $elt->first_child( $cond) or return undef;
  8191.     $elt->set_att( $att => $child->text);
  8192.     $child->cut;
  8193.     return $elt;
  8194.   }
  8195.  
  8196. sub att_to_field
  8197.   { my( $elt, $att, $tag)= @_;
  8198.     $tag ||= $att;
  8199.     my $child= $elt->insert_new_elt( first_child => $tag, $elt->{'att'}->{$att});
  8200.     $elt->del_att( $att);
  8201.     return $elt;
  8202.   }
  8203.  
  8204. # sort children methods
  8205.  
  8206. sub sort_children_on_field
  8207.   { my $elt   = shift;
  8208.     my $field = shift;
  8209.     my $get_key= sub { return $_[0]->field( $field) };
  8210.     return $elt->sort_children( $get_key, @_); 
  8211.   }
  8212.  
  8213. sub sort_children_on_att
  8214.   { my $elt = shift;
  8215.     my $att = shift;
  8216.     my $get_key= sub { return $_[0]->{'att'}->{$att} };
  8217.     return $elt->sort_children( $get_key, @_); 
  8218.   }
  8219.  
  8220. sub sort_children_on_value
  8221.   { my $elt   = shift;
  8222.     #my $get_key= eval qq{ sub { return \$_[0]->text } };
  8223.     my $get_key= \&text;
  8224.     return $elt->sort_children( $get_key, @_); 
  8225.   }
  8226.  
  8227.  
  8228. sub sort_children
  8229.   { my( $elt, $get_key, %opt)=@_;
  8230.     $opt{order} ||= 'normal';
  8231.     $opt{type}  ||= 'alpha';
  8232.     my( $par_a, $par_b)= ($opt{order} eq 'reverse') ? qw( b a) : qw ( a b) ;
  8233.     my $op= ($opt{type} eq 'numeric') ? '<=>' : 'cmp' ;
  8234.     my @children= $elt->cut_children;
  8235.     if( $opt{type} eq 'numeric')
  8236.       {  @children= map  { $_->[1] }
  8237.                     sort { $a->[0] <=> $b->[0] }
  8238.                     map  { [ $get_key->( $_), $_] } @children;
  8239.       }
  8240.     elsif( $opt{type} eq 'alpha')
  8241.       {  @children= map  { $_->[1] }
  8242.                     sort { $a->[0] cmp $b->[0] }
  8243.                     map  { [ $get_key->( $_), $_] } @children;
  8244.       }
  8245.     else
  8246.       { croak "wrong sort type '$opt{type}', should be either 'alpha' or 'numeric'"; }
  8247.  
  8248.     @children= reverse @children if( $opt{order} eq 'reverse');
  8249.     $elt->set_content( @children);
  8250.   }
  8251.  
  8252.  
  8253. # comparison methods
  8254.  
  8255. sub before
  8256.   { my( $a, $b)=@_;
  8257.     if( $a->cmp( $b) == -1) { return 1; } else { return 0; }
  8258.   }
  8259.  
  8260. sub after
  8261.   { my( $a, $b)=@_;
  8262.     if( $a->cmp( $b) == 1) { return 1; } else { return 0; }
  8263.   }
  8264.  
  8265. sub lt
  8266.   { my( $a, $b)=@_;
  8267.     return 1 if( $a->cmp( $b) == -1);
  8268.     return 0;
  8269.   }
  8270.  
  8271. sub le
  8272.   { my( $a, $b)=@_;
  8273.     return 1 unless( $a->cmp( $b) == 1);
  8274.     return 0;
  8275.   }
  8276.  
  8277. sub gt
  8278.   { my( $a, $b)=@_;
  8279.     return 1 if( $a->cmp( $b) == 1);
  8280.     return 0;
  8281.   }
  8282.  
  8283. sub ge
  8284.   { my( $a, $b)=@_;
  8285.     return 1 unless( $a->cmp( $b) == -1);
  8286.     return 0;
  8287.   }
  8288.  
  8289.  
  8290. sub cmp
  8291.   { my( $a, $b)=@_;
  8292.  
  8293.     # easy cases
  8294.     return  0 if( $a == $b);    
  8295.     return 1 if( $a->in($b)); # a starts after b 
  8296.     return -1 if( $b->in($a)); # a starts before b
  8297.  
  8298.     # ancestors does not include the element itself
  8299.     my @a_pile= ($a, $a->ancestors); 
  8300.     my @b_pile= ($b, $b->ancestors);
  8301.  
  8302.     # the 2 elements are not in the same twig
  8303.     return undef unless( $a_pile[-1] == $b_pile[-1]);
  8304.  
  8305.     # find the first non common ancestors (they are siblings)
  8306.     my $a_anc= pop @a_pile;
  8307.     my $b_anc= pop @b_pile;
  8308.  
  8309.     while( $a_anc == $b_anc) 
  8310.       { $a_anc= pop @a_pile;
  8311.         $b_anc= pop @b_pile;
  8312.       }
  8313.  
  8314.     # from there move left and right and figure out the order
  8315.     my( $a_prev, $a_next, $b_prev, $b_next)= ($a_anc, $a_anc, $b_anc, $b_anc);
  8316.     while()
  8317.       { $a_prev= $a_prev->{prev_sibling} || return( -1);
  8318.         return 1 if( $a_prev == $b_next);
  8319.         $a_next= $a_next->{next_sibling} || return( 1);
  8320.         return -1 if( $a_next == $b_prev);
  8321.         $b_prev= $b_prev->{prev_sibling} || return( 1);
  8322.         return -1 if( $b_prev == $a_next);
  8323.         $b_next= $b_next->{next_sibling} || return( -1);
  8324.         return 1 if( $b_next == $a_prev);
  8325.       }
  8326.   }
  8327.     
  8328. #end-extract twig_node
  8329.  
  8330. sub _dump
  8331.   { my( $elt, $option)= @_; 
  8332.   
  8333.     my $atts       = defined $option->{atts}       ? $option->{atts}       :  1;
  8334.     my $extra      = defined $option->{extra}      ? $option->{extra}      :  0;
  8335.     my $short_text = defined $option->{short_text} ? $option->{short_text} : 40;
  8336.  
  8337.     my $sp= '| ';
  8338.     my $indent= $sp x $elt->level;
  8339.     my $indent_sp= '  ' x $elt->level;
  8340.     
  8341.     my $dump='';
  8342.     if( $elt->is_elt)
  8343.       { if( $extra && $elt->extra_data)
  8344.           { my $extra_data = $indent . "|- (not a node) '" . $elt->extra_data;
  8345.             $extra_data=~ s{\n}{$indent_sp}g;
  8346.             $dump .= $extra_data . "\n";
  8347.           }
  8348.           
  8349.         $dump .= $indent  . '|-' . $XML::Twig::index2gi[$elt->{'gi'}];
  8350.         
  8351.         if( $atts && (my @atts= $elt->att_names) )
  8352.           { $dump .= ' ' . join( ' ', map { qq{$_="} . $elt->{'att'}->{$_} . qq{"} } @atts); }
  8353.  
  8354.         $dump .= "\n";
  8355.         $dump .= join( "", map { $_->_dump( $option) } $elt->children);
  8356.       }
  8357.     elsif( (exists $elt->{'pcdata'}))
  8358.       { $dump .= "$indent|-PCDATA:  '" . _short_text( $elt->{pcdata}, $short_text) . "'\n" }
  8359.     elsif( (exists $elt->{'cdata'}))
  8360.       { $dump .= "$indent|-CDATA:   '" . _short_text( $elt->{cdata}, $short_text) . "'\n" }
  8361.     elsif( (exists $elt->{'comment'}))
  8362.       { $dump .= "$indent|-COMMENT: '" . _short_text( $elt->comment_string, $short_text) . "'\n" }
  8363.     elsif( (exists $elt->{'target'}))
  8364.       { $dump .= "$indent|-PI: '"      . $elt->{target} . "' - '" . _short_text( $elt->{data}, $short_text) . "'\n" }
  8365.     return $dump;
  8366.   }
  8367.  
  8368. sub _short_text
  8369.   { my( $string, $length)= @_;
  8370.     if( !$length || (length( $string) < $length) ) { return $string; }
  8371.     my $l1= (length( $string) -5) /2;
  8372.     my $l2= length( $string) - ($l1 + 5);
  8373.     return substr( $string, 0, $l1) . ' ... ' . substr( $string, -$l2);
  8374.   }
  8375. 1;
  8376.  
  8377. __END__
  8378.  
  8379. =head1 NAME
  8380.  
  8381. XML::Twig - A perl module for processing huge XML documents in tree mode.
  8382.  
  8383. =head1 SYNOPSIS
  8384.  
  8385. Note that this documentation is intended as a reference to the module.
  8386.  
  8387. Complete docs, including a tutorial, examples, an easier to use HTML version,
  8388. a quick reference card and a FAQ are available at http://www.xmltwig.com/xmltwig
  8389.  
  8390. Small documents (loaded in memory as a tree):
  8391.  
  8392.   my $twig=XML::Twig->new();    # create the twig
  8393.   $twig->parsefile( 'doc.xml'); # build it
  8394.   my_process( $twig);           # use twig methods to process it 
  8395.   $twig->print;                 # output the twig
  8396.  
  8397. Huge documents (processed in combined stream/tree mode):
  8398.  
  8399.   # at most one div will be loaded in memory
  8400.   my $twig=XML::Twig->new(   
  8401.     twig_handlers => 
  8402.       { title   => sub { $_->set_tag( 'h2') }, # change title tags to h2
  8403.         para    => sub { $_->set_tag( 'p')  }, # change para to p
  8404.         hidden  => sub { $_->delete;       },  # remove hidden elements
  8405.         list    => \&my_list_process,          # process list elements
  8406.         div     => sub { $_[0]->flush;     },  # output and free memory
  8407.       },
  8408.     pretty_print => 'indented',                # output will be nicely formatted
  8409.     empty_tags   => 'html',                    # outputs <empty_tag />
  8410.                          );
  8411.     $twig->flush;                              # flush the end of the document
  8412.  
  8413. See L<XML::Twig 101|XML::Twig 101> for other ways to use the module, as a 
  8414. filter for example
  8415.  
  8416.  
  8417. =head1 DESCRIPTION
  8418.  
  8419. This module provides a way to process XML documents. It is build on top
  8420. of C<XML::Parser>.
  8421.  
  8422. The module offers a tree interface to the document, while allowing you
  8423. to output the parts of it that have been completely processed.
  8424.  
  8425. It allows minimal resource (CPU and memory) usage by building the tree
  8426. only for the parts of the documents that need actual processing, through the 
  8427. use of the C<L<twig_roots|twig_roots> > and 
  8428. C<L<twig_print_outside_roots|twig_print_outside_roots> > options. The 
  8429. C<L<finish|finish> > and C<L<finish_print|finish_print> > methods also help 
  8430. to increase performances.
  8431.  
  8432. XML::Twig tries to make simple things easy so it tries its best to takes care 
  8433. of a lot of the (usually) annoying (but sometimes necessary) features that 
  8434. come with XML and XML::Parser.
  8435.  
  8436. =head1 XML::Twig 101
  8437.  
  8438. XML::Twig can be used either on "small" XML documents (that fit in memory)
  8439. or on huge ones, by processing parts of the document and outputting or
  8440. discarding them once they are processed.
  8441.  
  8442.  
  8443. =head2 Loading an XML document and processing it
  8444.  
  8445.   my $t= XML::Twig->new();
  8446.   $t->parse( '<d><title>title</title><para>p 1</para><para>p 2</para></d>');
  8447.   my $root= $t->root;
  8448.   $root->set_tag( 'html');              # change doc to html
  8449.   $title= $root->first_child( 'title'); # get the title
  8450.   $title->set_tag( 'h1');               # turn it into h1
  8451.   my @para= $root->children( 'para');   # get the para children
  8452.   foreach my $para (@para)
  8453.     { $para->set_tag( 'p'); }           # turn them into p
  8454.   $t->print;                            # output the document
  8455.  
  8456. Other useful methods include:
  8457.  
  8458. L<att|att>: C<< $elt->{'att'}->{'foo'} >> return the C<foo> attribute for an 
  8459. element,
  8460.  
  8461. L<set_att|set_att> : C<< $elt->set_att( foo => "bar") >> sets the C<foo> 
  8462. attribute to the C<bar> value,
  8463.  
  8464. L<next_sibling|next_sibling>: C<< $elt->{next_sibling} >> return the next sibling
  8465. in the document (in the example C<< $title->{next_sibling} >> is the first
  8466. C<para>, you can also (and actually should) use 
  8467. C<< $elt->next_sibling( 'para') >> to get it 
  8468.  
  8469. The document can also be transformed through the use of the L<cut|cut>, 
  8470. L<copy|copy>, L<paste|paste> and L<move|move> methods: 
  8471. C<< $title->cut; $title->paste( after => $p); >> for example
  8472.  
  8473. And much, much more, see L<Elt|"Elt">.
  8474.  
  8475. =head2 Processing an XML document chunk by chunk
  8476.  
  8477. One of the strengths of XML::Twig is that it let you work with files that do 
  8478. not fit in memory (BTW storing an XML document in memory as a tree is quite
  8479. memory-expensive, the expansion factor being often around 10).
  8480.  
  8481. To do this you can define handlers, that will be called once a specific 
  8482. element has been completely parsed. In these handlers you can access the
  8483. element and process it as you see fit, using the navigation and the
  8484. cut-n-paste methods, plus lots of convenient ones like C<L<prefix|prefix> >.
  8485. Once the element is completely processed you can then C<L<flush|flush> > it, 
  8486. which will output it and free the memory. You can also C<L<purge|purge> > it 
  8487. if you don't need to output it (if you are just extracting some data from 
  8488. the document for example). The handler will be called again once the next 
  8489. relevant element has been parsed.
  8490.  
  8491.   my $t= XML::Twig->new( twig_handlers => 
  8492.                           { section => \§ion,
  8493.                             para   => sub { $_->set_tag( 'p');
  8494.                           },
  8495.                        );
  8496.   $t->parsefile( 'doc.xml');
  8497.   $t->flush; # don't forget to flush one last time in the end or anything
  8498.              # after the last </section> tag will not be output 
  8499.     
  8500.   # the handler is called once a section is completely parsed, ie when 
  8501.   # the end tag for section is found, it receives the twig itself and
  8502.   # the element (including all its sub-elements) as arguments
  8503.   sub section 
  8504.     { my( $t, $section)= @_;      # arguments for all twig_handlers
  8505.       $section->set_tag( 'div');  # change the tag name.4, my favourite method...
  8506.       # let's use the attribute nb as a prefix to the title
  8507.       my $title= $section->first_child( 'title'); # find the title
  8508.       my $nb= $title->{'att'}->{'nb'}; # get the attribute
  8509.       $title->prefix( "$nb - ");  # easy isn't it?
  8510.       $section->flush;            # outputs the section and frees memory
  8511.     }
  8512.  
  8513.         
  8514. There is of course more to it: you can trigger handlers on more elaborate 
  8515. conditions than just the name of the element, C<section/title> for example.
  8516.  
  8517.   my $t= XML::Twig->new( twig_handlers => 
  8518.                            { 'section/title' => sub { $_->print } }
  8519.                        )
  8520.                   ->parsefile( 'doc.xml');
  8521.  
  8522. Here C<< sub { $_->print } >> simply prints the current element (C<$_> is aliased
  8523. to the element in the handler).
  8524.  
  8525. You can also trigger a handler on a test on an attribute:
  8526.  
  8527.   my $t= XML::Twig->new( twig_handlers => 
  8528.                       { 'section[@level="1"]' => sub { $_->print } }
  8529.                        );
  8530.                   ->parsefile( 'doc.xml');
  8531.  
  8532. You can also use C<L<start_tag_handlers|start_tag_handlers> > to process an 
  8533. element as soon as the start tag is found. Besides C<L<prefix|prefix> > you
  8534. can also use C<L<suffix|suffix> >, 
  8535.  
  8536. =head2 Processing just parts of an XML document
  8537.  
  8538. The twig_roots mode builds only the required sub-trees from the document
  8539. Anything outside of the twig roots will just be ignored:
  8540.  
  8541.   my $t= XML::Twig->new( 
  8542.        # the twig will include just the root and selected titles 
  8543.            twig_roots   => { 'section/title' => \&print_n_purge,
  8544.                              'annex/title'   => \&print_n_purge
  8545.            }
  8546.                       );
  8547.   $t->parsefile( 'doc.xml');
  8548.   
  8549.   sub print_n_purge 
  8550.     { my( $t, $elt)= @_;
  8551.       print $elt->text;    # print the text (including sub-element texts)
  8552.       $t->purge;           # frees the memory
  8553.     }
  8554.  
  8555. You can use that mode when you want to process parts of a documents but are
  8556. not interested in the rest and you don't want to pay the price, either in
  8557. time or memory, to build the tree for the it.
  8558.  
  8559.  
  8560. =head2 Building an XML filter
  8561.  
  8562. You can combine the C<twig_roots> and the C<twig_print_outside_roots> options to 
  8563. build filters, which let you modify selected elements and will output the rest 
  8564. of the document as is.
  8565.  
  8566. This would convert prices in $ to prices in Euro in a document:
  8567.  
  8568.   my $t= XML::Twig->new( 
  8569.            twig_roots   => { 'price' => \&convert, },   # process prices 
  8570.            twig_print_outside_roots => 1,               # print the rest
  8571.                       );
  8572.   $t->parsefile( 'doc.xml');
  8573.  
  8574.   sub convert 
  8575.     { my( $t, $price)= @_;
  8576.       my $currency=  $price->{'att'}->{'currency'};          # get the currency
  8577.       if( $currency eq 'USD')
  8578.         { $usd_price= $price->text;                     # get the price
  8579.           # %rate is just a conversion table 
  8580.           my $euro_price= $usd_price * $rate{usd2euro};
  8581.           $price->set_text( $euro_price);               # set the new price
  8582.           $price->set_att( currency => 'EUR');          # don't forget this!
  8583.         }
  8584.       $price->print;                                    # output the price
  8585.     }
  8586.  
  8587. =head2 XML::Twig and various versions of Perl, XML::Parser and expat:
  8588.  
  8589. Before being uploaded to CPAN, XML::Twig 3.22 has been tested under the 
  8590. following environments:
  8591.  
  8592. =over 4
  8593.  
  8594. =item linux-x86
  8595.  
  8596. perl 5.6.2, expat 1.95.8, XML::Parser 2.34
  8597. perl 5.8.0, expat 1.95.8, XML::Parser 2.34
  8598. perl 5.8.7, expat 1.95.8, XML::Parser2.34
  8599.  
  8600. =item Solaris
  8601.  
  8602. perl 5.6.1, expat 1.95.2, XML::Parser 2.31
  8603.  
  8604. =back
  8605.  
  8606. XML::Twig is a lot more sensitive to variations in versions of perl, 
  8607. XML::Parser and expat than to the OS, so this should cover some
  8608. reasonable configurations.
  8609.  
  8610. The "recommended configuration" is perl 5.8.3+ (for good Unicode
  8611. support), XML::Parser 2.31+ and expat 1.95.5+
  8612.  
  8613. See L<http://testers.cpan.org/search?request=dist&dist=XML-Twig> for the
  8614. CPAN testers reports on XML::Twig, which list all tested configurations.
  8615.  
  8616. An Atom feed of the CPAN Testers results is available at
  8617. L<http://xmltwig.com/rss/twig_testers.rss>
  8618.  
  8619. Finally: 
  8620.  
  8621. =over 4
  8622.  
  8623. =item XML::Twig does B<NOT> work with expat 1.95.4
  8624.   
  8625. =item  XML::Twig only works with XML::Parser 2.27 in perl 5.6.*  
  8626.  
  8627. Note that I can't compile XML::Parser 2.27 anymore, so I can't garantee 
  8628. that it still works
  8629.  
  8630. =item XML::Parser 2.28 does not really work
  8631.  
  8632. =back
  8633.  
  8634. When in doubt, upgrade expat, XML::Parser and Scalar::Util
  8635.  
  8636. Finally, for some optional features, XML::Twig depends on some additional
  8637. modules. The complete list, which depends somewhat on the version of Perl
  8638. that you are running, is given by running C<t/zz_dump_config.t>
  8639.  
  8640. =head1 Simplifying XML processing
  8641.  
  8642. =over 4
  8643.  
  8644. =item Whitespaces
  8645.  
  8646. Whitespaces that look non-significant are discarded, this behaviour can be 
  8647. controlled using the C<L<keep_spaces|keep_spaces> >, 
  8648. C<L<keep_spaces_in|keep_spaces_in> > and 
  8649. C<L<discard_spaces_in|discard_spaces_in> > options.
  8650.  
  8651. =item Encoding
  8652.  
  8653. You can specify that you want the output in the same encoding as the input
  8654. (provided you have valid XML, which means you have to specify the encoding
  8655. either in the document or when you create the Twig object) using the 
  8656. C<L<keep_encoding|keep_encoding> > option
  8657.  
  8658. You can also use C<L<output_encoding>> to convert the internal UTF-8 format
  8659. to the required encoding.
  8660.  
  8661. =item Comments and Processing Instructions (PI)
  8662.  
  8663. Comments and PI's can be hidden from the processing, but still appear in the
  8664. output (they are carried by the "real" element closer to them)
  8665.  
  8666. =item Pretty Printing
  8667.  
  8668. XML::Twig can output the document pretty printed so it is easier to read for
  8669. us humans.
  8670.  
  8671. =item Surviving an untimely death
  8672.  
  8673. XML parsers are supposed to react violently when fed improper XML. 
  8674. XML::Parser just dies.
  8675.  
  8676. XML::Twig provides the C<L<safe_parse|safe_parse> > and the 
  8677. C<L<safe_parsefile|safe_parsefile> > methods which wrap the parse in an eval
  8678. and return either the parsed twig or 0 in case of failure.
  8679.  
  8680. =item Private attributes
  8681.  
  8682. Attributes with a name starting with # (illegal in XML) will not be
  8683. output, so you can safely use them to store temporary values during
  8684. processing. Note that you can store anything in a private attribute, 
  8685. not just text, it's just a regular Perl variable, so a reference to
  8686. an object or a huge data structure is perfectly fine.
  8687.  
  8688. =back
  8689.  
  8690. =head1 CLASSES
  8691.  
  8692. XML::Twig uses a very limited number of classes. The ones you are most likely to use
  8693. are C<L<XML::Twig>> of course, which represents a complete XML document, including the 
  8694. document itself (the root of the document itself is C<L<root>>), its handlers, its
  8695. input or output filters... The other main class is C<L<XML::Twig::Elt>>, which models 
  8696. an XML element. Element here has a very wide definition: it can be a regular element, or
  8697. but also text, with an element C<L<tag>> of C<#PCDATA> (or C<#CDATA>), an entity (tag is
  8698. C<#ENT>), a Processing Instruction (C<#PI>), a comment (C<#COMMENT>). 
  8699.  
  8700. Those are the 2 commonly used classes.
  8701.  
  8702. You might want to look the C<L<elt_class>> option if you want to subclass C<XML::Twig::Elt>.
  8703.  
  8704. Attributes are just attached to their parent element, they are not objects per se. (Please
  8705. use the provided methods C<L<att>> and C<L<set_att>> to access them, if you access them
  8706. as a hash, then your code becomes implementaion deppndant and might break in the future).
  8707.  
  8708. Other classes that are seldom used are C<L<XML::Twig::Entity_list>> and C<L<XML::Twig::Entity>>.
  8709.  
  8710. If you use C<L<XML::Twig::XPath>> instead of C<XML::Twig>, elements are then created as
  8711. C<L<XML::Twig::XPath::Elt>>
  8712.  
  8713.  
  8714. =head1 METHODS
  8715.  
  8716. =head2 XML::Twig 
  8717.  
  8718. A twig is a subclass of XML::Parser, so all XML::Parser methods can be
  8719. called on a twig object, including parse and parsefile.
  8720. C<setHandlers> on the other hand cannot be used, see C<L<BUGS|BUGS> >
  8721.  
  8722.  
  8723. =over 4
  8724.  
  8725. =item new 
  8726.  
  8727. This is a class method, the constructor for XML::Twig. Options are passed
  8728. as keyword value pairs. Recognized options are the same as XML::Parser,
  8729. plus some XML::Twig specifics.
  8730.  
  8731. New Options:
  8732.  
  8733. =over 4
  8734.  
  8735. =item twig_handlers
  8736.  
  8737. This argument replaces the corresponding XML::Parser argument. It consists
  8738. of a hash C<{ expression => \&handler}> where expression is a 
  8739. I<generic_attribute_condition>, I<string_condition>,
  8740. an I<attribute_condition>,I<full_path>, a I<partial_path>, a I<tag>,
  8741. a I<tag_regexp>, I<_default_> or I<_all_>.
  8742.  
  8743. The idea is to support a usefull but efficient (thus limited) subset of
  8744. XPATH. A fuller expression set will be supported in the future, as users
  8745. ask for more and as I manage to implement it efficiently. This will never
  8746. encompass all of XPATH due to the streaming nature of parsing (no lookahead
  8747. after the element end tag).
  8748.  
  8749. A B<generic_attribute_condition> is a condition on an attribute, in the form
  8750. C<*[@att="val"]> or C<*[@att]>, simple quotes can be used instead of double 
  8751. quotes and the leading '*' is actually optional. No matter what the tag of the
  8752. element is, the handler will be triggered either if the attribute has the 
  8753. specified value or if it just exists. 
  8754.  
  8755. A B<string_condition> is a condition on the content of an element, in the form
  8756. C<tag[string()="foo"]>, simple quotes can be used instead of double quotes, at 
  8757. the moment you cannot escape the quotes (this will be added as soon as I
  8758. dig out my copy of Mastering Regular Expressions from its storage box).
  8759. The text returned is, as per what I (and Matt Sergeant!) understood from
  8760. the XPATH spec the concatenation of all the text in the element, excluding
  8761. all markup. Thus to call a handler on the elementC<< <p>text <b>bold</b></p> >>
  8762. the appropriate condition is C<p[string()="text bold"]>. Note that this is not
  8763. exactly conformant to the XPATH spec, it just tries to mimic it while being
  8764. still quite concise. 
  8765.  
  8766. A extension of that notation is C<tag[string(B<child_tag>)="foo"]> where the
  8767. handler will be called if a child of a C<tag> element has a text value of 
  8768. C<foo>.  At the moment only direct children of the C<tag> element are checked.
  8769. If you need to test on descendants of the element let me know. The fix is
  8770. trivial but would slow down the checks, so I'd like to keep it the way it is.
  8771.  
  8772. A B<regexp_condition> is a condition on the content of an element, in the form
  8773. C<tag[string()=~ /foo/"]>. This is the same as a string condition except that
  8774. the text of the element is matched to the regexp. The C<i>, C<m>, C<s> and C<o>
  8775. modifiers can be used on the regexp.
  8776.  
  8777. The C<< tag[string(B<child_tag>)=~ /foo/"] >> extension is also supported.
  8778.  
  8779. An B<attribute_condition> is a simple condition of an attribute of the
  8780. current element in the form C<tag[@att="val"]> (simple quotes can be used
  8781. instead of double quotes, you can escape quotes either). 
  8782. If several attribute_condition are true the same element all the handlers
  8783. can be called in turn (in the order in which they were first defined).
  8784. If the C<="val"> part is ommited ( the condition is then C<tag[@att]>) then
  8785. the handler is triggered if the attribute actually exists for the element,
  8786. no matter what it's value is.
  8787.  
  8788. A B<full_path> looks like C<'/doc/section/chapter/title'>, it starts with
  8789. a / then lists all the tags to the element. The handler will be called if
  8790. the path to the current element (in the input document) is exactly as
  8791. defined by the C<full_path>.
  8792.  
  8793. A B<partial_path> is like a full_path except it does not start with a /:
  8794. C<'chapter/title'> for example. The handler will be called if the path to
  8795. the element (in the input document) ends as defined in the C<partial_path>.
  8796.  
  8797. B<WARNING>: (hopefully temporary) at the moment C<string_condition>, 
  8798. C<regexp_condition> and C<attribute_condition> are only supported on a 
  8799. simple tag, not on a path.
  8800.  
  8801. A B<tag_regexp> is a regular expression (created with C<qr//>), applied to 
  8802. the tag name. For example C<qr/^h\d$/i> would match C<h1>, C<H1>, C<h2>, 
  8803. C<H2>... 
  8804.  
  8805. A B<tag>.
  8806.  
  8807. #CDATA can be used to call a handler for a CDATA.
  8808.  
  8809. A special tag B<_all_> is used to call a function for each element.
  8810. The special tag B<_default_> is used to call a handler for each element
  8811. that does NOT have a specific handler.
  8812.  
  8813. The order of precedence to trigger a handler is: 
  8814. I<generic_attribute_condition>, I<string_condition>, I<regexp_condition>, 
  8815. I<attribute_condition>, I<full_path>, longer I<partial_path>, shorter 
  8816. I<partial_path>, I<tag_regexp>, I<tag>, I<_default_> . 
  8817.  
  8818. B<Important>: once a handler has been triggered if it returns 0 then no other
  8819. handler is called, exept a C<_all_> handler which will be called anyway.
  8820.  
  8821. If a handler returns a true value and other handlers apply, then the next
  8822. applicable handler will be called. Repeat, rince, lather..; The exception
  8823. to that rule is when the C<L<do_not_chain_handlers|do_not_chain_handlers>>
  8824. option is set, in which case only the first handler will be called.
  8825.  
  8826. Note that it might be a good idea to explicitely return a short true value
  8827. (like 1) from handlers: this ensures that other applicable handlers are 
  8828. called even if the last statement for the handler happens to evaluate to
  8829. false. This might also speedup the code by avoiding the result of the last 
  8830. statement of the code to be copied and passed to the code managing handlers.
  8831. It can really pay to have 1 instead of a long string returned.
  8832.  
  8833. When an element is CLOSED the corresponding handler is called, with 2
  8834. arguments: the twig and the C<L</Element|/Element> >. The twig includes the 
  8835. document tree that has been built so far, the element is the complete sub-tree
  8836. for the element. This means that handlers for inner elements are called before
  8837. handlers for outer elements.
  8838.  
  8839. C<$_> is also set to the element, so it is easy to write inline handlers like
  8840.  
  8841.   para => sub { $_->set_tag( 'p'); }
  8842.  
  8843. Text is stored in elements whose tag is #PCDATA (due to mixed content, text
  8844. and sub-element in an element there is no way to store the text as just an
  8845. attribute of the enclosing element).
  8846.  
  8847. B<Warning>: if you have used purge or flush on the twig the element might not
  8848. be complete, some of its children might have been entirely flushed or purged,
  8849. and the start tag might even have been printed (by C<flush>) already, so changing
  8850. its tag might not give the expected result.
  8851.  
  8852. More generally, the I<full_path>, I<partial_path>, I<tag> and I<tag_regexp> 
  8853. expressions are
  8854. evaluated against the input document. Which means that even if you have changed
  8855. the tag of an element (changing the tag of a parent element from a handler for
  8856. example) the change will not impact the expression evaluation. Attributes in
  8857. I<attribute_condition> are different though. As the initial value of attribute
  8858. is not stored the handler will be triggered if the B<current> attribute/value
  8859. pair is found when the element end tag is found. Although this can be quite
  8860. confusing it should not impact most of users, and allow others to play clever
  8861. tricks with temporary attributes. Let me know if this is a problem for you.
  8862.  
  8863.  
  8864. =item twig_roots
  8865.  
  8866. This argument let's you build the tree only for those elements you are
  8867. interested in. 
  8868.  
  8869.   Example: my $t= XML::Twig->new( twig_roots => { title => 1, subtitle => 1});
  8870.            $t->parsefile( file);
  8871.            my $t= XML::Twig->new( twig_roots => { 'section/title' => 1});
  8872.            $t->parsefile( file);
  8873.  
  8874.  
  8875. return a twig containing a document including only C<title> and C<subtitle> 
  8876. elements, as children of the root element.
  8877.  
  8878. You can use I<generic_attribute_condition>, I<attribute_condition>,
  8879. I<full_path>, I<partial_path>, I<tag>, I<tag_regexp>, I<_default_> and 
  8880. I<_all_> to trigger the building of the twig. 
  8881. I<string_condition> and I<regexp_condition> cannot be used as the content 
  8882. of the element, and the string, have not yet been parsed when the condition
  8883. is checked.
  8884.  
  8885. B<WARNING>: path are checked for the document. Even if the C<twig_roots> option
  8886. is used they will be checked against the full document tree, not the virtual
  8887. tree created by XML::Twig
  8888.  
  8889.  
  8890. B<WARNING>: twig_roots elements should NOT be nested, that would hopelessly
  8891. confuse XML::Twig ;--(
  8892.  
  8893. Note: you can set handlers (twig_handlers) using twig_roots
  8894.   Example: my $t= XML::Twig->new( twig_roots => 
  8895.                                    { title    => sub { $_{1]->print;}, 
  8896.                                      subtitle => \&process_subtitle 
  8897.                                    }
  8898.                                );
  8899.            $t->parsefile( file);
  8900.  
  8901.  
  8902. =item twig_print_outside_roots
  8903.  
  8904. To be used in conjunction with the C<twig_roots> argument. When set to a true 
  8905. value this will print the document outside of the C<twig_roots> elements.
  8906.  
  8907.  Example: my $t= XML::Twig->new( twig_roots => { title => \&number_title },
  8908.                                 twig_print_outside_roots => 1,
  8909.                                );
  8910.            $t->parsefile( file);
  8911.            { my $nb;
  8912.            sub number_title
  8913.              { my( $twig, $title);
  8914.                $nb++;
  8915.                $title->prefix( "$nb "; }
  8916.                $title->print;
  8917.              }
  8918.            }
  8919.                
  8920.  
  8921. This example prints the document outside of the title element, calls 
  8922. C<number_title> for each C<title> element, prints it, and then resumes printing
  8923. the document. The twig is built only for the C<title> elements. 
  8924.  
  8925. If the value is a reference to a file handle then the document outside the
  8926. C<twig_roots> elements will be output to this file handle:
  8927.  
  8928.   open( OUT, ">out_file") or die "cannot open out file out_file:$!";
  8929.   my $t= XML::Twig->new( twig_roots => { title => \&number_title },
  8930.                          # default output to OUT
  8931.                          twig_print_outside_roots => \*OUT, 
  8932.                        );
  8933.  
  8934.          { my $nb;
  8935.            sub number_title
  8936.              { my( $twig, $title);
  8937.                $nb++;
  8938.                $title->prefix( "$nb "; }
  8939.                $title->print( \*OUT);    # you have to print to \*OUT here
  8940.              }
  8941.            }
  8942.  
  8943.  
  8944. =item start_tag_handlers
  8945.  
  8946. A hash C<{ expression => \&handler}>. Sets element handlers that are called when
  8947. the element is open (at the end of the XML::Parser C<Start> handler). The handlers
  8948. are called with 2 params: the twig and the element. The element is empty at 
  8949. that point, its attributes are created though. 
  8950.  
  8951. You can use I<generic_attribute_condition>, I<attribute_condition>,
  8952. I<full_path>, I<partial_path>, I<tag>, I<tag_regexp>, I<_default_>  and I<_all_> 
  8953. to trigger the handler. 
  8954.  
  8955. I<string_condition> and I<regexp_condition> cannot be used as the content of 
  8956. the element, and the string, have not yet been parsed when the condition is 
  8957. checked.
  8958.  
  8959. The main uses for those handlers are to change the tag name (you might have to 
  8960. do it as soon as you find the open tag if you plan to C<flush> the twig at some
  8961. point in the element, and to create temporary attributes that will be used
  8962. when processing sub-element with C<twig_hanlders>. 
  8963.  
  8964. You should also use it to change tags if you use C<flush>. If you change the tag 
  8965. in a regular C<twig_handler> then the start tag might already have been flushed. 
  8966.  
  8967. B<Note>: C<start_tag> handlers can be called outside of C<twig_roots> if this 
  8968. argument is used, in this case handlers are called with the following arguments:
  8969. C<$t> (the twig), C<$tag> (the tag of the element) and C<%att> (a hash of the 
  8970. attributes of the element). 
  8971.  
  8972. If the C<twig_print_outside_roots> argument is also used, if the last handler
  8973. called returns  a C<true> value, then the the start tag will be output as it
  8974. appeared in the original document, if the handler returns a a C<false> value
  8975. then the start tag will B<not> be printed (so you can print a modified string 
  8976. yourself for example).
  8977.  
  8978. Note that you can use the L<ignore|ignore> method in C<start_tag_handlers> 
  8979. (and only there). 
  8980.  
  8981. =item end_tag_handlers
  8982.  
  8983. A hash C<{ expression => \&handler}>. Sets element handlers that are called when
  8984. the element is closed (at the end of the XML::Parser C<End> handler). The handlers
  8985. are called with 2 params: the twig and the tag of the element. 
  8986.  
  8987. I<twig_handlers> are called when an element is completely parsed, so why have 
  8988. this redundant option? There is only one use for C<end_tag_handlers>: when using
  8989. the C<twig_roots> option, to trigger a handler for an element B<outside> the roots.
  8990. It is for example very useful to number titles in a document using nested 
  8991. sections: 
  8992.  
  8993.   my @no= (0);
  8994.   my $no;
  8995.   my $t= XML::Twig->new( 
  8996.           start_tag_handlers => 
  8997.            { section => sub { $no[$#no]++; $no= join '.', @no; push @no, 0; } },
  8998.           twig_roots         => 
  8999.            { title   => sub { $_[1]->prefix( $no); $_[1]->print; } },
  9000.           end_tag_handlers   => { section => sub { pop @no;  } },
  9001.           twig_print_outside_roots => 1
  9002.                       );
  9003.    $t->parsefile( $file);
  9004.  
  9005. Using the C<end_tag_handlers> argument without C<twig_roots> will result in an
  9006. error.
  9007.  
  9008. =item do_not_chain_handlers
  9009.  
  9010. If this option is set to a true value, then only one handler will be called for
  9011. each element, even if several satisfy the condition
  9012.  
  9013. Note that the C<_all_> handler will still be called regardeless
  9014.  
  9015. =item ignore_elts
  9016.  
  9017. This option lets you ignore elements when building the twig. This is useful 
  9018. in cases where you cannot use C<twig_roots> to ignore elements, for example if
  9019. the element to ignore is a sibling of elements you are interested in.
  9020.  
  9021. Example:
  9022.  
  9023.   my $twig= XML::Twig->new( ignore_elts => { elt => 1 });
  9024.   $twig->parsefile( 'doc.xml');
  9025.  
  9026. This will build the complete twig for the document, except that all C<elt> 
  9027. elements (and their children) will be left out.
  9028.  
  9029.  
  9030. =item char_handler
  9031.  
  9032. A reference to a subroutine that will be called every time C<PCDATA> is found.
  9033.  
  9034. The subroutine receives the string as argument, and returns the modified string:
  9035.  
  9036.   # we want all strings in upper case
  9037.   sub my_char_handler
  9038.     { my( $text)= @_;
  9039.       $text= uc( $text);
  9040.       return $text;
  9041.     }
  9042.  
  9043. =item elt_class
  9044.  
  9045. The name of a class used to store elements. this class should inherit from
  9046. C<XML::Twig::Elt> (and by default it is C<XML::Twig::Elt>). This option is used
  9047. to subclass the element class and extend it with new methods.
  9048.  
  9049. This option is needed because during the parsing of the XML, elements are created
  9050. by C<XML::Twig>, without any control from the user code.
  9051.  
  9052. =item keep_atts_order
  9053.  
  9054. Setting this option to a true value causes the attribute hash to be tied to
  9055. a C<Tie::IxHash> object.
  9056. This means that C<Tie::IxHash> needs to be installed for this option to be 
  9057. available. It also means that the hash keeps its order, so you will get 
  9058. the attributes in order. This allows outputing the attributes in the same 
  9059. order as they were in the original document.
  9060.  
  9061. =item keep_encoding
  9062.  
  9063. This is a (slightly?) evil option: if the XML document is not UTF-8 encoded and
  9064. you want to keep it that way, then setting keep_encoding will use theC<Expat> 
  9065. original_string method for character, thus keeping the original encoding, as 
  9066. well as the original entities in the strings.
  9067.  
  9068. See the C<t/test6.t> test file to see what results you can expect from the 
  9069. various encoding options.
  9070.  
  9071. B<WARNING>: if the original encoding is multi-byte then attribute parsing will
  9072. be EXTREMELY unsafe under any Perl before 5.6, as it uses regular expressions
  9073. which do not deal properly with multi-byte characters. You can specify an 
  9074. alternate function to parse the start tags with the C<parse_start_tag> option 
  9075. (see below)
  9076.  
  9077. B<WARNING>: this option is NOT used when parsing with the non-blocking parser 
  9078. (C<parse_start>, C<parse_more>, parse_done methods) which you probably should 
  9079. not use with XML::Twig anyway as they are totally untested!
  9080.  
  9081. =item output_encoding
  9082.  
  9083. This option generates an output_filter using C<Encode>,  C<Text::Iconv> or 
  9084. C<Unicode::Map8> and C<Unicode::Strings>, and sets the encoding in the XML
  9085. declaration. This is the easiest way to deal with encodings, if you need 
  9086. more sophisticated features, look at C<output_filter> below
  9087.  
  9088.  
  9089. =item output_filter
  9090.  
  9091. This option is used to convert the character encoding of the output document.
  9092. It is passed either a string corresponding to a predefined filter or
  9093. a subroutine reference. The filter will be called every time a document or 
  9094. element is processed by the "print" functions (C<print>, C<sprint>, C<flush>). 
  9095.  
  9096. Pre-defined filters: 
  9097.  
  9098. =over 4 
  9099.  
  9100. =item latin1 
  9101.  
  9102. uses either C<Encode>, C<Text::Iconv> or C<Unicode::Map8> and C<Unicode::String>
  9103. or a regexp (which works only with XML::Parser 2.27), in this order, to convert 
  9104. all characters to ISO-8859-1 (aka latin1)
  9105.  
  9106. =item html
  9107.  
  9108. does the same conversion as C<latin1>, plus encodes entities using
  9109. C<HTML::Entities> (oddly enough you will need to have HTML::Entities intalled 
  9110. for it to be available). This should only be used if the tags and attribute 
  9111. names themselves are in US-ASCII, or they will be converted and the output will
  9112. not be valid XML any more
  9113.  
  9114. =item safe
  9115.  
  9116. converts the output to ASCII (US) only  plus I<character entities> (C<&#nnn;>) 
  9117. this should be used only if the tags and attribute names themselves are in 
  9118. US-ASCII, or they will be converted and the output will not be valid XML any 
  9119. more
  9120.  
  9121. =item safe_hex
  9122.  
  9123. same as C<safe> except that the character entities are in hexa (C<&#xnnn;>)
  9124.  
  9125. =item encode_convert ($encoding)
  9126.  
  9127. Return a subref that can be used to convert utf8 strings to C<$encoding>).
  9128. Uses C<Encode>.
  9129.  
  9130.    my $conv = XML::Twig::encode_convert( 'latin1');
  9131.    my $t = XML::Twig->new(output_filter => $conv);
  9132.  
  9133. =item iconv_convert ($encoding)
  9134.  
  9135. this function is used to create a filter subroutine that will be used to 
  9136. convert the characters to the target encoding using C<Text::Iconv> (which needs
  9137. to be installed, look at the documentation for the module and for the
  9138. C<iconv> library to find out which encodings are available on your system)
  9139.  
  9140.    my $conv = XML::Twig::iconv_convert( 'latin1');
  9141.    my $t = XML::Twig->new(output_filter => $conv);
  9142.  
  9143. =item unicode_convert ($encoding)
  9144.  
  9145. this function is used to create a filter subroutine that will be used to 
  9146. convert the characters to the target encoding using  C<Unicode::Strings> 
  9147. and C<Unicode::Map8> (which need to be installed, look at the documentation 
  9148. for the modules to find out which encodings are available on your system)
  9149.  
  9150.    my $conv = XML::Twig::unicode_convert( 'latin1');
  9151.    my $t = XML::Twig->new(output_filter => $conv);
  9152.  
  9153. =back
  9154.  
  9155. The C<text> and C<att> methods do not use the filter, so their 
  9156. result are always in unicode.
  9157.  
  9158. Those predeclared filters are based on subroutines that can be used
  9159. by themselves (as C<XML::Twig::foo>). 
  9160.  
  9161. =over 4
  9162.  
  9163. =item html_encode ($string)
  9164.  
  9165. Use C<HTML::Entities> to encode a utf8 string
  9166.  
  9167. =item safe_encode ($string)
  9168.  
  9169. Use either a regexp (perl < 5.8) or C<Encode> to encode non-ascii characters
  9170. in the string in C<< &#<nnnn>; >> format
  9171.  
  9172. =item safe_encode_hex ($string)
  9173.  
  9174. Use either a regexp (perl < 5.8) or C<Encode> to encode non-ascii characters
  9175. in the string in C<< &#x<nnnn>; >> format
  9176.  
  9177. =item regexp2latin1 ($string)
  9178.  
  9179. Use a regexp to encode a utf8 string into latin 1 (ISO-8859-1). Does not
  9180. work with Perl 5.8.0!
  9181.  
  9182. =back
  9183.  
  9184. =item output_text_filter
  9185.  
  9186. same as output_filter, except it doesn't apply to the brackets and quotes 
  9187. around attribute values. This is useful for all filters that could change
  9188. the tagging, basically anything that does not just change the encoding of
  9189. the output. C<html>, C<safe> and C<safe_hex> are better used with this option.
  9190.  
  9191. =item input_filter
  9192.  
  9193. This option is similar to C<output_filter> except the filter is applied to 
  9194. the characters before they are stored in the twig, at parsing time.
  9195.  
  9196. =item remove_cdata
  9197.  
  9198. Setting this option to a true value will force the twig to output CDATA 
  9199. sections as regular (escaped) PCDATA
  9200.  
  9201. =item parse_start_tag
  9202.  
  9203. If you use the C<keep_encoding> option then this option can be used to replace
  9204. the default parsing function. You should provide a coderef (a reference to a 
  9205. subroutine) as the argument, this subroutine takes the original tag (given
  9206. by XML::Parser::Expat C<original_string()> method) and returns a tag and the
  9207. attributes in a hash (or in a list attribute_name/attribute value).
  9208.  
  9209. =item expand_external_ents
  9210.  
  9211. When this option is used external entities (that are defined) are expanded
  9212. when the document is output using "print" functions such as C<L<print> >,
  9213. C<L<sprint|sprint> >, C<L<flush|flush> > and C<L<xml_string|xml_string> >. 
  9214. Note that in the twig the entity will be stored as an element whith a 
  9215. tag 'C<#ENT>', the entity will not be expanded there, so you might want to 
  9216. process the entities before outputting it. 
  9217.  
  9218. =item load_DTD
  9219.  
  9220. If this argument is set to a true value, C<parse> or C<parsefile> on the twig
  9221. will load  the DTD information. This information can then be accessed through 
  9222. the twig, in a C<DTD_handler> for example. This will load even an external DTD.
  9223.  
  9224. Default and fixed values for attributes will also be filled, based on the DTD.
  9225.  
  9226. Note that to do this the module will generate a temporary file in the current
  9227. directory. If this is a problem let me know and I will add an option to
  9228. specify an alternate directory.
  9229.  
  9230. See L<DTD Handling|DTD Handling> for more information
  9231.  
  9232. =item DTD_handler
  9233.  
  9234. Set a handler that will be called once the doctype (and the DTD) have been 
  9235. loaded, with 2 arguments, the twig and the DTD.
  9236.  
  9237. =item no_prolog
  9238.  
  9239. Does not output a prolog (XML declaration and DTD)
  9240.  
  9241. =item id
  9242.  
  9243. This optional argument gives the name of an attribute that can be used as
  9244. an ID in the document. Elements whose ID is known can be accessed through
  9245. the elt_id method. id defaults to 'id'.
  9246. See C<L<BUGS|BUGS> >
  9247.  
  9248. =item discard_spaces
  9249.  
  9250. If this optional argument is set to a true value then spaces are discarded
  9251. when they look non-significant: strings containing only spaces are discarded.
  9252. This argument is set to true by default.
  9253.  
  9254. =item keep_spaces
  9255.  
  9256. If this optional argument is set to a true value then all spaces in the
  9257. document are kept, and stored as C<PCDATA>.
  9258.  
  9259. B<Warning>: adding this option can result in changes in the twig generated:
  9260. space that was previously discarded might end up in a new text element. see
  9261. the difference by calling the following code with 0 and 1 as arguments:
  9262.  
  9263.   perl -MXML::Twig -e'print XML::Twig->new( keep_spaces => shift)->parse( "<d> \n<e/></d>")->_dump'
  9264.  
  9265.  
  9266. C<keep_spaces> and C<discard_spaces> cannot be both set.
  9267.  
  9268. =item discard_spaces_in
  9269.  
  9270. This argument sets C<keep_spaces> to true but will cause the twig builder to
  9271. discard spaces in the elements listed.
  9272.  
  9273. The syntax for using this argument is:
  9274.  
  9275.   XML::Twig->new( discard_spaces_in => [ 'elt1', 'elt2']);
  9276.  
  9277. =item keep_spaces_in
  9278.  
  9279. This argument sets C<discard_spaces> to true but will cause the twig builder to
  9280. keep spaces in the elements listed.
  9281.  
  9282. The syntax for using this argument is: 
  9283.  
  9284.   XML::Twig->new( keep_spaces_in => [ 'elt1', 'elt2']);
  9285.  
  9286. B<Warning>: adding this option can result in changes in the twig generated:
  9287. space that was previously discarded might end up in a new text element.
  9288.  
  9289. =item pretty_print
  9290.  
  9291. Set the pretty print method, amongst 'C<none>' (default), 'C<nsgmls>', 
  9292. 'C<nice>', 'C<indented>', 'C<indented_c>', C<wrapped>, 'C<record>' and 
  9293. 'C<record_c>'
  9294.  
  9295. pretty_print formats:
  9296.  
  9297. =over 4
  9298.  
  9299. =item none
  9300.  
  9301. The document is output as one ling string, with no line breaks except those 
  9302. found within text elements
  9303.  
  9304. =item nsgmls
  9305.  
  9306. Line breaks are inserted in safe places: that is within tags, between a tag 
  9307. and an attribute, between attributes and before the > at the end of a tag.
  9308.  
  9309. This is quite ugly but better than C<none>, and it is very safe, the document 
  9310. will still be valid (conforming to its DTD).
  9311.  
  9312. This is how the SGML parser C<sgmls> splits documents, hence the name.
  9313.  
  9314. =item nice
  9315.  
  9316. This option inserts line breaks before any tag that does not contain text (so
  9317. element with textual content are not broken as the \n is the significant).
  9318.  
  9319. B<WARNING>: this option leaves the document well-formed but might make it
  9320. invalid (not conformant to its DTD). If you have elements declared as
  9321.  
  9322.   <!ELEMENT foo (#PCDATA|bar)>
  9323.  
  9324. then a C<foo> element including a C<bar> one will be printed as
  9325.  
  9326.   <foo>
  9327.   <bar>bar is just pcdata</bar>
  9328.   </foo>
  9329.  
  9330. This is invalid, as the parser will take the line break after the C<foo> tag 
  9331. as a sign that the element contains PCDATA, it will then die when it finds the 
  9332. C<bar> tag. This may or may not be important for you, but be aware of it!
  9333.  
  9334. =item indented
  9335.  
  9336. Same as C<nice> (and with the same warning) but indents elements according to 
  9337. their level 
  9338.  
  9339. =item indented_c
  9340.  
  9341. Same as C<indented> but a little more compact: the closing tags are on the 
  9342. same line as the preceeding text
  9343.  
  9344. =item wrapped
  9345.  
  9346. Same as C<indented_c> but lines are wrapped using L<Text::Wrap::wrap>. The 
  9347. default length for lines is the default for C<$Text::Wrap::columns>, and can
  9348. be changed by changing that variable.
  9349.  
  9350. =item record
  9351.  
  9352. This is a record-oriented pretty print, that display data in records, one field 
  9353. per line (which looks a LOT like C<indented>)
  9354.  
  9355. =item record_c
  9356.  
  9357. Stands for record compact, one record per line
  9358.  
  9359. =back
  9360.  
  9361.  
  9362. =item empty_tags
  9363.  
  9364. Set the empty tag display style ('C<normal>', 'C<html>' or 'C<expand>').
  9365.  
  9366. C<normal> outputs an empty tag 'C<< <tag/> >>', C<html> adds a space 
  9367. 'C<< <tag /> >>' for elements that can be empty in XHTML and C<expand> outputs
  9368. 'C<< <tag></tag> >>'
  9369.  
  9370. =item comments
  9371.  
  9372. Set the way comments are processed: 'C<drop>' (default), 'C<keep>' or 
  9373. 'C<process>' 
  9374.  
  9375. Comments processing options:
  9376.  
  9377. =over 4
  9378.  
  9379. =item drop
  9380.  
  9381. drops the comments, they are not read, nor printed to the output
  9382.  
  9383. =item keep
  9384.  
  9385. comments are loaded and will appear on the output, they are not 
  9386. accessible within the twig and will not interfere with processing
  9387. though
  9388.  
  9389. B<Note>: comments in the middle of a text element such as 
  9390.  
  9391.   <p>text <!-- comment --> more text --></p>
  9392.  
  9393. are kept at their original position in the text. Using "print"
  9394. methods like C<print> or C<sprint> will return the comments in the
  9395. text. Using C<text> or C<field> on the other hand will not.
  9396.  
  9397. Any use of C<set_pcdata> on the C<#PCDATA> element (directly or 
  9398. through other methods like C<set_content>) will delete the comment(s).
  9399.  
  9400. =item process
  9401.  
  9402. comments are loaded in the twig and will be treated as regular elements 
  9403. (their C<tag> is C<#COMMENT>) this can interfere with processing if you
  9404. expect C<< $elt->{first_child} >> to be an element but find a comment there.
  9405. Validation will not protect you from this as comments can happen anywhere.
  9406. You can use C<< $elt->first_child( 'tag') >> (which is a good habit anyway)
  9407. to get where you want. 
  9408.  
  9409. Consider using C<process> if you are outputing SAX events from XML::Twig.
  9410.  
  9411. =back
  9412.  
  9413. =item pi
  9414.  
  9415. Set the way processing instructions are processed: 'C<drop>', 'C<keep>' 
  9416. (default) or 'C<process>'
  9417.  
  9418. Note that you can also set PI handlers in the C<twig_handlers> option: 
  9419.  
  9420.   '?'       => \&handler
  9421.   '?target' => \&handler 2
  9422.  
  9423. The handlers will be called with 2 parameters, the twig and the PI element if
  9424. C<pi> is set to C<process>, and with 3, the twig, the target and the data if
  9425. C<pi> is set to C<keep>. Of course they will not be called if C<pi> is set to 
  9426. C<drop>.
  9427.  
  9428. If C<pi> is set to C<keep> the handler should return a string that will be used
  9429. as-is as the PI text (it should look like "C< <?target data?> >" or '' if you
  9430. want to remove the PI), 
  9431.  
  9432. Only one handler will be called, C<?target> or C<?> if no specific handler for
  9433. that target is available.
  9434.  
  9435. =item map_xmlns 
  9436.  
  9437. This option is passed a hashref that maps uri's to prefixes. The prefixes in
  9438. the document will be replaced by the ones in the map. The mapped prefixes can
  9439. (actually have to) be used to trigger handlers, navigate or query the document.
  9440.  
  9441. Here is an example:
  9442.  
  9443.   my $t= XML::Twig->new( map_xmlns => {'http://www.w3.org/2000/svg' => "svg"},
  9444.                          twig_handlers => 
  9445.                            { 'svg:circle' => sub { $_->set_att( r => 20) } },
  9446.                          pretty_print => 'indented', 
  9447.                        )
  9448.                   ->parse( '<doc xmlns:gr="http://www.w3.org/2000/svg">
  9449.                               <gr:circle cx="10" cy="90" r="10"/>
  9450.                            </doc>'
  9451.                          )
  9452.                   ->print;
  9453.  
  9454. This will output:
  9455.  
  9456.   <doc xmlns:svg="http://www.w3.org/2000/svg">
  9457.      <svg:circle cx="10" cy="90" r="20"/>
  9458.   </doc>
  9459.  
  9460. =item keep_original_prefix
  9461.  
  9462. When used with C<L<map_xmlns>> this option will make C<XML::Twig> use the original
  9463. namespace prefixes when outputing a document. The mapped prefix will still be used
  9464. for triggering handlers and in navigation and query methods.
  9465.  
  9466.   my $t= XML::Twig->new( map_xmlns => {'http://www.w3.org/2000/svg' => "svg"},
  9467.                          twig_handlers => 
  9468.                            { 'svg:circle' => sub { $_->set_att( r => 20) } },
  9469.                          keep_original_prefix => 1,
  9470.                          pretty_print => 'indented', 
  9471.                        )
  9472.                   ->parse( '<doc xmlns:gr="http://www.w3.org/2000/svg">
  9473.                               <gr:circle cx="10" cy="90" r="10"/>
  9474.                            </doc>'
  9475.                          )
  9476.                   ->print;
  9477.  
  9478. This will output:
  9479.  
  9480.   <doc xmlns:gr="http://www.w3.org/2000/svg">
  9481.      <gr:circle cx="10" cy="90" r="20"/>
  9482.   </doc>
  9483.  
  9484. =item index ($arrayref or $hashref)
  9485.  
  9486. This option creates lists of specific elements during the parsing of the XML.
  9487. It takes a reference to either a list of triggering expressions or to a hash 
  9488. name => expression, and for each one generates the list of elements that 
  9489. match the expression. The list can be accessed through the C<L<index>> method.
  9490.  
  9491. example:
  9492.  
  9493.   # using an array ref
  9494.   my $t= XML::Twig->new( index => [ 'div', 'table' ])
  9495.                   ->parsefile( "foo.xml');
  9496.   my $divs= $t->index( 'div');
  9497.   my $first_div= $divs->[0];
  9498.   my $last_table= $t->index( table => -1);
  9499.  
  9500.   # using a hashref to name the indexes
  9501.   my $t= XML::Twig->new( index => { email => 'a[@href=~/^\s*mailto:/]')
  9502.                   ->parsefile( "foo.xml');
  9503.   my $last_emails= $t->index( email => -1);
  9504.  
  9505. Note that the index is not maintained after the parsing. If elements are 
  9506. deleted, renamed or otherwise hurt during processing, the index is NOT updated.
  9507.  
  9508.  
  9509. =back
  9510.  
  9511. B<Note>: I _HATE_ the Java-like name of arguments used by most XML modules.
  9512. So in pure TIMTOWTDI fashion all arguments can be written either as
  9513. C<UglyJavaLikeName> or as C<readable_perl_name>: C<twig_print_outside_roots>
  9514. or C<TwigPrintOutsideRoots> (or even C<twigPrintOutsideRoots> {shudder}). 
  9515. XML::Twig normalizes them before processing them.
  9516.  
  9517. =item parse ( $source)
  9518.  
  9519. The C<$source> parameter should either be a string containing the whole XML
  9520. document, or it should be an open C<IO::Handle>. Constructor options to
  9521. C<XML::Parser::Expat> given as keyword-value pairs may follow theC<$source> 
  9522. parameter. These override, for this call, any options or attributes passed
  9523. through from the XML::Parser instance.
  9524.  
  9525. A die call is thrown if a parse error occurs. Otherwise it will return 
  9526. the twig built by the parse. Use C<safe_parse> if you want the parsing
  9527. to return even when an error occurs.
  9528.  
  9529. =item parsestring
  9530.  
  9531. This is just an alias for C<parse> for backwards compatibility.
  9532.  
  9533. =item parsefile (FILE [, OPT => OPT_VALUE [...]])
  9534.  
  9535. Open C<FILE> for reading, then call C<parse> with the open handle. The file
  9536. is closed no matter how C<parse> returns. 
  9537.  
  9538. A C<die> call is thrown if a parse error occurs. Otherwise it will return 
  9539. the twig built by the parse. Use C<safe_parsefile> if you want the parsing
  9540. to return even when an error occurs.
  9541.  
  9542. =item parsefile_inplace ( $file, $optional_extension)
  9543.  
  9544. Parse and update a file "in place". It does this by creating a temp file,
  9545. selecting it as the default for print() statements (and methods), then parsing
  9546. the input file. If the parsing is successful, then the temp file is 
  9547. moved to replace the input file.
  9548.  
  9549. If an extension is given then the original file is backed-up (the rules for
  9550. the extension are the same as the rule for the -i option in perl).
  9551.  
  9552. =item parsefile_html_inplace ( $file, $optional_extension)
  9553.  
  9554. Same as parsefile_inplace, except that it parses HTML instead of XML 
  9555.  
  9556. =item parseurl ($url $optional_user_agent)
  9557.  
  9558. Gets the data from C<$url> and parse it. The data is piped to the parser in 
  9559. chunks the size of the XML::Parser::Expat buffer, so memory consumption and
  9560. hopefully speed are optimal.
  9561.  
  9562. For most (read "small") XML it is probably as efficient (and easier to debug)
  9563. to just C<get> the XML file and then parse it as a string.
  9564.  
  9565.   use XML::Twig;
  9566.   use LWP::Simple;
  9567.   my $twig= XML::Twig->new();
  9568.   $twig->parse( get( $URL )); # get is exported by LWP::Simple
  9569.  
  9570. or
  9571.  
  9572.   use XML::Twig;
  9573.   my $twig= XML::Twig->nparse( $URL);
  9574.  
  9575.  
  9576. If the C<$optional_user_agent> argument is used then it is used, otherwise a
  9577. new one is created.
  9578.  
  9579. =item safe_parse ( SOURCE [, OPT => OPT_VALUE [...]])
  9580.  
  9581. This method is similar to C<parse> except that it wraps the parsing in an
  9582. C<eval> block. It returns the twig on success and 0 on failure (the twig object
  9583. also contains the parsed twig). C<$@> contains the error message on failure.
  9584.  
  9585. Note that the parsing still stops as soon as an error is detected, there is
  9586. no way to keep going after an error.
  9587.  
  9588. =item safe_parsefile (FILE [, OPT => OPT_VALUE [...]])
  9589.  
  9590. This method is similar to C<parsefile> except that it wraps the parsing in an
  9591. C<eval> block. It returns the twig on success and 0 on failure (the twig object
  9592. also contains the parsed twig) . C<$@> contains the error message on failure
  9593.  
  9594. Note that the parsing still stops as soon as an error is detected, there is
  9595. no way to keep going after an error.
  9596.  
  9597. =item safe_parseurl ($url $optional_user_agent)
  9598.  
  9599. Same as C<parseurl> except that it wraps the parsing in an C<eval> block. It 
  9600. returns the twig on success and 0 on failure (the twig object also contains
  9601. the parsed twig) . C<$@> contains the error message on failure
  9602.  
  9603. =item parse_html
  9604.  
  9605. parse an HTML string or file handle (by converting it to XML using
  9606. HTML::TreeBuilder, which needs to be available).
  9607.  
  9608. B<Alpha>: implementation, and thus generated XML could change. 
  9609.  
  9610. =item parsefile_html
  9611.  
  9612. parse an HTML file (by converting it to XML using HTML::TreeBuilder, which 
  9613. needs to be available). The file is loaded completely in memory and converted
  9614. to XML before being parsed.
  9615.  
  9616. B<Alpha>: implementation, and thus generated XML could change. 
  9617.  
  9618. =item xparse ($thing_to_parse)
  9619.  
  9620. parse the C<$thing_to_parse>, whether it is a filehandle, a string, an HTML 
  9621. file, an HTML URL, an URL or a file.
  9622.  
  9623. Note that this is mostly a convenience method for one-off scripts. For example
  9624. files that end in '.htm' or '.html' are parsed first as XML, and if this fails
  9625. as HTML. This is certainly not the most efficient way to do this in general.
  9626.  
  9627. =item nparse ($optional_twig_options, $thing_to_parse)
  9628.  
  9629. create a twig with the C<$optional_options>, and parse the C<$thing_to_parse>, 
  9630. whether it is a filehandle, a string, an HTML file, an HTML URL, an URL or a 
  9631. file.
  9632.  
  9633. Examples:
  9634.  
  9635.    XML::Twig->nparse( "file.xml");
  9636.    XML::Twig->nparse( error_context => 1, "file://file.xml");
  9637.  
  9638.  
  9639. =item parser
  9640.  
  9641. This method returns the C<expat> object (actually the XML::Parser::Expat object) 
  9642. used during parsing. It is useful for example to call XML::Parser::Expat methods
  9643. on it. To get the line of a tag for example use C<< $t->parser->current_line >>.
  9644.  
  9645. =item setTwigHandlers ($handlers)
  9646.  
  9647. Set the twig_handlers. C<$handlers> is a reference to a hash similar to the
  9648. one in the C<twig_handlers> option of new. All previous handlers are unset.
  9649. The method returns the reference to the previous handlers.
  9650.  
  9651. =item setTwigHandler ($exp $handler)
  9652.  
  9653. Set a single twig_handler for elements matching C<$exp>. C<$handler> is a 
  9654. reference to a subroutine. If the handler was previously set then the reference 
  9655. to the previous handler is returned.
  9656.  
  9657. =item setStartTagHandlers ($handlers)
  9658.  
  9659. Set the start_tag handlers. C<$handlers> is a reference to a hash similar to the
  9660. one in the C<start_tag_handlers> option of new. All previous handlers are unset.
  9661. The method returns the reference to the previous handlers.
  9662.  
  9663. =item setStartTagHandler ($exp $handler)
  9664.  
  9665. Set a single start_tag handlers for elements matching C<$exp>. C<$handler> is a 
  9666. reference to a subroutine. If the handler was previously set then the reference
  9667. to the previous handler is returned.
  9668.  
  9669. =item setEndTagHandlers ($handlers)
  9670.  
  9671. Set the end_tag handlers. C<$handlers> is a reference to a hash similar to the
  9672. one in the C<end_tag_handlers> option of new. All previous handlers are unset.
  9673. The method returns the reference to the previous handlers.
  9674.  
  9675. =item setEndTagHandler ($exp $handler)
  9676.  
  9677. Set a single end_tag handlers for elements matching C<$exp>. C<$handler> is a 
  9678. reference to a subroutine. If the handler was previously set then the 
  9679. reference to the previous handler is returned.
  9680.  
  9681. =item setTwigRoots ($handlers)
  9682.  
  9683. Same as using the C<L<twig_roots>> option when creating the twig
  9684.  
  9685. =item setCharHandler ($exp $handler)
  9686.  
  9687. Set a C<char_handler>
  9688.  
  9689. =item setIgnoreEltsHandler ($exp)
  9690.  
  9691. Set a C<ignore_elt> handler (elements that match C<$exp> will be ignored
  9692.  
  9693. =item setIgnoreEltsHandlers ($exp)
  9694.  
  9695. Set all C<ignore_elt> handlers (previous handlers are replaced)
  9696.  
  9697. =item dtd
  9698.  
  9699. Return the dtd (an L<XML::Twig::DTD> object) of a twig
  9700.  
  9701. =item xmldecl
  9702.  
  9703. Return the XML declaration for the document, or a default one if it doesn't
  9704. have one
  9705.  
  9706. =item doctype
  9707.  
  9708. Return the doctype for the document
  9709.  
  9710. =item dtd_text
  9711.  
  9712. Return the DTD text
  9713.  
  9714. =item dtd_print
  9715.  
  9716. Print the DTD
  9717.  
  9718. =item model ($tag)
  9719.  
  9720. Return the model (in the DTD) for the element C<$tag>
  9721.  
  9722. =item root
  9723.  
  9724. Return the root element of a twig
  9725.  
  9726. =item set_root ($elt)
  9727.  
  9728. Set the root of a twig
  9729.  
  9730. =item first_elt ($optional_condition)
  9731.  
  9732. Return the first element matching C<$optional_condition> of a twig, if
  9733. no condition is given then the root is returned
  9734.  
  9735. =item last_elt ($optional_condition)
  9736.  
  9737. Return the last element matching C<$optional_condition> of a twig, if
  9738. no condition is given then the last element of the twig is returned
  9739.  
  9740. =item elt_id        ($id)
  9741.  
  9742. Return the element whose C<id> attribute is $id
  9743.  
  9744. =item getEltById
  9745.  
  9746. Same as C<L<elt_id>>
  9747.  
  9748. =item index ($index_name, $optional_index)
  9749.  
  9750. If the C<$optional_index> argument is present, return the corresponding element
  9751. in the index (created using the C<index> option for C<XML::Twig->new>)
  9752.  
  9753. If the argument is not present, return an arrayref to the index
  9754.  
  9755. =item encoding
  9756.  
  9757. This method returns the encoding of the XML document, as defined by the 
  9758. C<encoding> attribute in the XML declaration (ie it is C<undef> if the attribute
  9759. is not defined)
  9760.  
  9761. =item set_encoding
  9762.  
  9763. This method sets the value of the C<encoding> attribute in the XML declaration. 
  9764. Note that if the document did not have a declaration it is generated (with
  9765. an XML version of 1.0)
  9766.  
  9767. =item xml_version
  9768.  
  9769. This method returns the XML version, as defined by the C<version> attribute in 
  9770. the XML declaration (ie it is C<undef> if the attribute is not defined)
  9771.  
  9772. =item set_xml_version
  9773.  
  9774. This method sets the value of the C<version> attribute in the XML declaration. 
  9775. If the declaration did not exist it is created.
  9776.  
  9777. =item standalone
  9778.  
  9779. This method returns the value of the C<standalone> declaration for the document
  9780.  
  9781. =item set_standalone
  9782.  
  9783. This method sets the value of the C<standalone> attribute in the XML 
  9784. declaration.  Note that if the document did not have a declaration it is 
  9785. generated (with an XML version of 1.0)
  9786.  
  9787. =item set_output_encoding
  9788.  
  9789. Set the C<encoding> "attribute" in the XML declaration
  9790.  
  9791. =item set_doctype ($name, $system, $public, $internal)
  9792.  
  9793. Set the doctype of the element. If an argument is C<undef> (or not present)
  9794. then its former value is retained, if a false ('' or 0) value is passed then
  9795. the former value is deleted;
  9796.  
  9797. =item entity_list
  9798.  
  9799. Return the entity list of a twig
  9800.  
  9801. =item entity_names
  9802.  
  9803. Return the list of all defined entities
  9804.  
  9805. =item entity ($entity_name)
  9806.  
  9807. Return the entity 
  9808.  
  9809. =item change_gi      ($old_gi, $new_gi)
  9810.  
  9811. Performs a (very fast) global change. All elements C<$old_gi> are now 
  9812. C<$new_gi>. This is a bit dangerous though and should be avoided if
  9813. < possible, as the new tag might be ignored in subsequent processing.
  9814.  
  9815. See C<L<BUGS|BUGS> >
  9816.  
  9817. =item flush            ($optional_filehandle, $options)
  9818.  
  9819. Flushes a twig up to (and including) the current element, then deletes
  9820. all unnecessary elements from the tree that's kept in memory.
  9821. C<flush> keeps track of which elements need to be open/closed, so if you
  9822. flush from handlers you don't have to worry about anything. Just keep 
  9823. flushing the twig every time you're done with a sub-tree and it will
  9824. come out well-formed. After the whole parsing don't forget toC<flush> 
  9825. one more time to print the end of the document.
  9826. The doctype and entity declarations are also printed.
  9827.  
  9828. flush take an optional filehandle as an argument.
  9829.  
  9830. options: use the C<update_DTD> option if you have updated the (internal) DTD 
  9831. and/or the entity list and you want the updated DTD to be output 
  9832.  
  9833. The C<pretty_print> option sets the pretty printing of the document.
  9834.  
  9835.    Example: $t->flush( Update_DTD => 1);
  9836.             $t->flush( \*FILE, Update_DTD => 1);
  9837.             $t->flush( \*FILE);
  9838.  
  9839.  
  9840. =item flush_up_to ($elt, $optional_filehandle, %options)
  9841.  
  9842. Flushes up to the C<$elt> element. This allows you to keep part of the
  9843. tree in memory when you C<flush>.
  9844.  
  9845. options: see flush.
  9846.  
  9847. =item purge
  9848.  
  9849. Does the same as a C<flush> except it does not print the twig. It just deletes
  9850. all elements that have been completely parsed so far.
  9851.  
  9852. =item purge_up_to ($elt)
  9853.  
  9854. Purges up to the C<$elt> element. This allows you to keep part of the tree in 
  9855. memory when you C<purge>.
  9856.  
  9857. =item print            ($optional_filehandle, %options)
  9858.  
  9859. Prints the whole document associated with the twig. To be used only AFTER the
  9860. parse.
  9861.  
  9862. options: see C<flush>.
  9863.  
  9864. =item print_to_file    ($filename, %options)
  9865.  
  9866. Prints the whole document associated with the twig to file C<$filename>.
  9867. To be used only AFTER the parse.
  9868.  
  9869. options: see C<flush>.
  9870.  
  9871. =item sprint
  9872.  
  9873. Return the text of the whole document associated with the twig. To be used only
  9874. AFTER the parse.
  9875.  
  9876. options: see C<flush>.
  9877.  
  9878. =item trim
  9879.  
  9880. Trim the document: gets rid of initial and trailing spaces, and relace multiple spaces
  9881. by a single one.
  9882.  
  9883. =item toSAX1 ($handler)
  9884.  
  9885. Send SAX events for the twig to the SAX1 handler C<$handler>
  9886.  
  9887. =item toSAX2 ($handler)
  9888.  
  9889. Send SAX events for the twig to the SAX2 handler C<$handler>
  9890.  
  9891. =item flush_toSAX1 ($handler)
  9892.  
  9893. Same as flush, except that SAX events are sent to the SAX1 handler
  9894. C<$handler> instead of the twig being printed
  9895.  
  9896. =item flush_toSAX2 ($handler)
  9897.  
  9898. Same as flush, except that SAX events are sent to the SAX2 handler
  9899. C<$handler> instead of the twig being printed
  9900.  
  9901. =item ignore
  9902.  
  9903. This method can B<only> be called in C<start_tag_handlers>. It causes the 
  9904. element to be skipped during the parsing: the twig is not built for this 
  9905. element, it will not be accessible during parsing or after it. The element 
  9906. will not take up any memory and parsing will be faster.
  9907.  
  9908. Note that this method can also be called on an element. If the element is a 
  9909. parent of the current element then this element will be ignored (the twig will
  9910. not be built any more for it and what has already been built will be deleted)
  9911.  
  9912.  
  9913. =item set_pretty_print  ($style)
  9914.  
  9915. Set the pretty print method, amongst 'C<none>' (default), 'C<nsgmls>', 
  9916. 'C<nice>', 'C<indented>', C<indented_c>, 'C<wrapped>', 'C<record>' and 
  9917. 'C<record_c>'
  9918.  
  9919. B<WARNING:> the pretty print style is a B<GLOBAL> variable, so once set it's
  9920. applied to B<ALL> C<print>'s (and C<sprint>'s). Same goes if you use XML::Twig
  9921. with C<mod_perl> . This should not be a problem as the XML that's generated 
  9922. is valid anyway, and XML processors (as well as HTML processors, including
  9923. browsers) should not care. Let me know if this is a big problem, but at the
  9924. moment the performance/cleanliness trade-off clearly favors the global 
  9925. approach.
  9926.  
  9927. =item set_empty_tag_style  ($style)
  9928.  
  9929. Set the empty tag display style ('C<normal>', 'C<html>' or 'C<expand>'). As 
  9930. with C<L<set_pretty_print>> this sets a global flag.  
  9931.  
  9932. C<normal> outputs an empty tag 'C<< <tag/> >>', C<html> adds a space 
  9933. 'C<< <tag /> >>' for elements that can be empty in XHTML and C<expand> outputs
  9934. 'C<< <tag></tag> >>'
  9935.  
  9936. =item set_remove_cdata  ($flag)
  9937.  
  9938. set (or unset) the flag that forces the twig to output CDATA sections as 
  9939. regular (escaped) PCDATA
  9940.  
  9941. =item print_prolog     ($optional_filehandle, %options)
  9942.  
  9943. Prints the prolog (XML declaration + DTD + entity declarations) of a document.
  9944.  
  9945. options: see C<L<flush>>.
  9946.  
  9947. =item prolog     ($optional_filehandle, %options)
  9948.  
  9949. Return the prolog (XML declaration + DTD + entity declarations) of a document.
  9950.  
  9951. options: see C<L<flush>>.
  9952.  
  9953. =item finish
  9954.  
  9955. Call Expat C<finish> method.
  9956. Unsets all handlers (including internal ones that set context), but expat
  9957. continues parsing to the end of the document or until it finds an error.
  9958. It should finish up a lot faster than with the handlers set.
  9959.  
  9960. =item finish_print
  9961.  
  9962. Stop twig processing, flush the twig and proceed to finish printing the 
  9963. document as fast as possible. Use this method when modifying a document and 
  9964. the modification is done. 
  9965.  
  9966. =item set_expand_external_entities
  9967.  
  9968. Same as using the C<L<expand_external_ents>> option when creating the twig
  9969.  
  9970. =item set_input_filter
  9971.  
  9972. Same as using the C<L<input_filter>> option when creating the twig
  9973.  
  9974. =item set_keep_atts_order
  9975.  
  9976. Same as using the C<L<keep_atts_order>> option when creating the twig
  9977.  
  9978. =item set_keep_encoding
  9979.  
  9980. Same as using the C<L<keep_encoding>> option when creating the twig
  9981.  
  9982. =item set_output_filter
  9983.  
  9984. Same as using the C<L<output_filter>> option when creating the twig
  9985.  
  9986. =item set_output_text_filter
  9987.  
  9988. Same as using the C<L<output_text_filter>> option when creating the twig
  9989.  
  9990. =item add_stylesheet ($type, @options)
  9991.  
  9992. Adds an external stylesheet to an XML document.
  9993.  
  9994. Supported types and options:
  9995.  
  9996. =over 4
  9997.  
  9998. =item xsl
  9999.  
  10000. option: the url of the stylesheet
  10001.  
  10002. Example:
  10003.  
  10004.   $t->add_stylesheet( xsl => "xsl_style.xsl");
  10005.  
  10006. will generate the following PI at the beginning of the document:
  10007.  
  10008.   <?xml-stylesheet type="text/xsl" href="xsl_style.xsl"?>
  10009.  
  10010. =item css
  10011.  
  10012. option: the url of the stylesheet
  10013.  
  10014.  
  10015. =back
  10016.  
  10017. =item Methods inherited from XML::Parser::Expat
  10018.  
  10019. A twig inherits all the relevant methods from XML::Parser::Expat. These 
  10020. methods can only be used during the parsing phase (they will generate
  10021. a fatal error otherwise).
  10022.  
  10023. Inherited methods are:
  10024.  
  10025. =over 4
  10026.  
  10027. =item depth
  10028.  
  10029. Returns the size of the context list.
  10030.  
  10031. =item in_element
  10032.  
  10033. Returns true if NAME is equal to the name of the innermost
  10034. currently opened element. If namespace processing is being used and
  10035. you want to check against a name that may be in a namespace, then
  10036. use the generate_ns_name method to create the NAME argument.
  10037.  
  10038. =item within_element
  10039.  
  10040. Returns the number of times the given name appears in the context
  10041. list.  If namespace processing is being used and you want to check
  10042. against a name that may be in a namespace, then use the
  10043. generate_ns_name method to create the NAME argument.
  10044.  
  10045. =item context
  10046.  
  10047. Returns a list of element names that represent open elements, with
  10048. the last one being the innermost. Inside start and end tag
  10049. handlers, this will be the tag of the parent element.
  10050.  
  10051. =item current_line
  10052.  
  10053. Returns the line number of the current position of the parse.
  10054.  
  10055. =item current_column
  10056.  
  10057. Returns the column number of the current position of the parse.
  10058.  
  10059. =item current_byte
  10060.  
  10061. Returns the current position of the parse.
  10062.  
  10063. =item position_in_context
  10064.  
  10065. Returns a string that shows the current parse position. LINES
  10066. should be an integer >= 0 that represents the number of lines on
  10067. either side of the current parse line to place into the returned
  10068. string.
  10069.  
  10070. =item base ([NEWBASE])
  10071.  
  10072. Returns the current value of the base for resolving relative URIs.
  10073. If NEWBASE is supplied, changes the base to that value.
  10074.  
  10075. =item current_element
  10076.  
  10077. Returns the name of the innermost currently opened element. Inside
  10078. start or end handlers, returns the parent of the element associated
  10079. with those tags.
  10080.  
  10081. =item element_index
  10082.  
  10083. Returns an integer that is the depth-first visit order of the
  10084. current element. This will be zero outside of the root element. For
  10085. example, this will return 1 when called from the start handler for
  10086. the root element start tag.
  10087.  
  10088. =item recognized_string
  10089.  
  10090. Returns the string from the document that was recognized in order
  10091. to call the current handler. For instance, when called from a start
  10092. handler, it will give us the the start-tag string. The string is
  10093. encoded in UTF-8.  This method doesn't return a meaningful string
  10094. inside declaration handlers.
  10095.  
  10096. =item original_string
  10097.  
  10098. Returns the verbatim string from the document that was recognized
  10099. in order to call the current handler. The string is in the original
  10100. document encoding. This method doesn't return a meaningful string
  10101. inside declaration handlers.
  10102.  
  10103. =item xpcroak
  10104.  
  10105. Concatenate onto the given message the current line number within
  10106. the XML document plus the message implied by ErrorContext. Then
  10107. croak with the formed message.
  10108.  
  10109. =item xpcarp 
  10110.  
  10111. Concatenate onto the given message the current line number within
  10112. the XML document plus the message implied by ErrorContext. Then
  10113. carp with the formed message.
  10114.  
  10115. =item xml_escape(TEXT [, CHAR [, CHAR ...]])
  10116.  
  10117. Returns TEXT with markup characters turned into character entities.
  10118. Any additional characters provided as arguments are also turned
  10119. into character references where found in TEXT.
  10120.  
  10121. (this method is broken on some versions of expat/XML::Parser)
  10122.  
  10123. =back
  10124.  
  10125. =item path ( $optional_tag)
  10126.  
  10127. Return the element context in a form similar to XPath's short
  10128. form: 'C</root/tag1/../tag>'
  10129.  
  10130. =item get_xpath  ( $optional_array_ref, $xpath, $optional_offset)
  10131.  
  10132. Performs a C<get_xpath> on the document root (see <Elt|"Elt">)
  10133.  
  10134. If the C<$optional_array_ref> argument is used the array must contain
  10135. elements. The C<$xpath> expression is applied to each element in turn 
  10136. and the result is union of all results. This way a first query can be
  10137. refined in further steps.
  10138.  
  10139.  
  10140. =item find_nodes ( $optional_array_ref, $xpath, $optional_offset)
  10141.  
  10142. same as C<get_xpath> 
  10143.  
  10144. =item findnodes ( $optional_array_ref, $xpath, $optional_offset)
  10145.  
  10146. same as C<get_xpath> (similar to the XML::LibXML method)
  10147.  
  10148. =item findvalue ( $optional_array_ref, $xpath, $optional_offset)
  10149.  
  10150. Return the C<join> of all texts of the results of appling C<L<get_xpath>>
  10151. to the node (similar to the XML::LibXML method)
  10152.  
  10153. =item subs_text ($regexp, $replace)
  10154.  
  10155. subs_text does text substitution on the whole document, similar to perl's 
  10156. C< s///> operator.
  10157.  
  10158. =item dispose
  10159.  
  10160. Useful only if you don't have C<Scalar::Util> or C<WeakRef> installed.
  10161.  
  10162. Reclaims properly the memory used by an XML::Twig object. As the object has
  10163. circular references it never goes out of scope, so if you want to parse lots 
  10164. of XML documents then the memory leak becomes a problem. Use
  10165. C<< $twig->dispose >> to clear this problem.
  10166.  
  10167. =item create_accessors (list_of_attribute_names)
  10168.  
  10169. A convenience method that creates l-valued accessors for attributes. 
  10170. So C<< $twig->create_accessors( 'foo') >> will create a C<foo> method
  10171. that can be called on elements:
  10172.  
  10173.   $elt->foo;         # equivalent to $elt->{'att'}->{'foo'};
  10174.   $elt->foo( 'bar'); # equivalent to $elt->set_att( foo => 'bar');
  10175.  
  10176. =item set_do_not_escape_amp_in_atts
  10177.  
  10178. An evil method, that I only document because Test::Pod::Coverage complaints otherwise,
  10179. but really, you don't want to know about it.
  10180.  
  10181. =back 
  10182.  
  10183. =head2 XML::Twig::Elt
  10184.  
  10185. =over 4
  10186.  
  10187. =item new          ($optional_tag, $optional_atts, @optional_content)
  10188.  
  10189. The C<tag> is optional (but then you can't have a content ), the C<$optional_atts> 
  10190. argument is a refreference to a hash of attributes, the content can be just a 
  10191. string or a list of strings and element. A content of 'C<#EMPTY>' creates an empty 
  10192. element;
  10193.  
  10194.  Examples: my $elt= XML::Twig::Elt->new();
  10195.            my $elt= XML::Twig::Elt->new( para => { align => 'center' });  
  10196.            my $elt= XML::Twig::Elt->new( para => { align => 'center' }, 'foo');  
  10197.            my $elt= XML::Twig::Elt->new( br   => '#EMPTY');
  10198.            my $elt= XML::Twig::Elt->new( 'para');
  10199.            my $elt= XML::Twig::Elt->new( para => 'this is a para');  
  10200.            my $elt= XML::Twig::Elt->new( para => $elt3, 'another para'); 
  10201.  
  10202. The strings are not parsed, the element is not attached to any twig.
  10203.  
  10204. B<WARNING>: if you rely on ID's then you will have to set the id yourself. At
  10205. this point the element does not belong to a twig yet, so the ID attribute
  10206. is not known so it won't be strored in the ID list.
  10207.  
  10208. Note that C<#COMMENT>, C<#PCDATA> or C<#CDATA> are valid tag names, that will 
  10209. create text elements.
  10210.  
  10211. To create an element C<foo> containing a CDATA section:
  10212.  
  10213.            my $foo= XML::Twig::Elt->new( '#CDATA' => "content of the CDATA section")
  10214.                                   ->wrap_in( 'foo');
  10215.  
  10216. An attribute of '#CDATA', will create the content of the attribute as CDATA:
  10217.  
  10218.   my $elt= XML::Twig::Elt->new( 'p' => { #CDATA => 1}, 'foo < bar');
  10219.  
  10220. creates an element 
  10221.  
  10222.   <p><![CDATA[foo < bar]]></>
  10223.  
  10224. =item parse         ($string, %args)
  10225.  
  10226. Creates an element from an XML string. The string is actually
  10227. parsed as a new twig, then the root of that twig is returned.
  10228. The arguments in C<%args> are passed to the twig.
  10229. As always if the parse fails the parser will die, so use an
  10230. eval if you want to trap syntax errors.
  10231.  
  10232. As obviously the element does not exist beforehand this method has to be 
  10233. called on the class: 
  10234.  
  10235.   my $elt= parse XML::Twig::Elt( "<a> string to parse, with <sub/>
  10236.                                   <elements>, actually tons of </elements>
  10237.                   h</a>");
  10238.  
  10239. =item set_inner_xml ($string)
  10240.  
  10241. Sets the content of the element to be the tree created from the string
  10242.  
  10243. =item set_inner_html ($string)
  10244.  
  10245. Sets the content of the element, after parsing the string with an HTML
  10246. parser (HTML::Parser)
  10247.  
  10248. =item print         ($optional_filehandle, $optional_pretty_print_style)
  10249.  
  10250. Prints an entire element, including the tags, optionally to a 
  10251. C<$optional_filehandle>, optionally with a C<$pretty_print_style>.
  10252.  
  10253. The print outputs XML data so base entities are escaped.
  10254.  
  10255. =item sprint       ($elt, $optional_no_enclosing_tag)
  10256.  
  10257. Return the xml string for an entire element, including the tags. 
  10258. If the optional second argument is true then only the string inside the 
  10259. element is returned (the start and end tag for $elt are not).
  10260. The text is XML-escaped: base entities (& and < in text, & < and " in
  10261. attribute values) are turned into entities.
  10262.  
  10263. =item gi                       
  10264.  
  10265. Return the gi of the element (the gi is the C<generic identifier> the tag
  10266. name in SGML parlance).
  10267.  
  10268. C<tag> and C<name> are synonyms of C<gi>.
  10269.  
  10270. =item tag
  10271.  
  10272. Same as C<L<gi|gi>>
  10273.  
  10274. =item name
  10275.  
  10276. Same as C<L<tag|tag>>
  10277.  
  10278. =item set_gi         ($tag)
  10279.  
  10280. Set the gi (tag) of an element
  10281.  
  10282. =item set_tag        ($tag)
  10283.  
  10284. Set the tag (=C<L<tag|tag>>) of an element
  10285.  
  10286. =item set_name       ($name)
  10287.  
  10288. Set the name (=C<L<tag|tag>>) of an element
  10289.  
  10290. =item root 
  10291.  
  10292. Return the root of the twig in which the element is contained.
  10293.  
  10294. =item twig 
  10295.  
  10296. Return the twig containing the element. 
  10297.  
  10298. =item parent        ($optional_condition)
  10299.  
  10300. Return the parent of the element, or the first ancestor matching the 
  10301. C<$optional_condition>
  10302.  
  10303. =item first_child   ($optional_condition)
  10304.  
  10305. Return the first child of the element, or the first child matching the 
  10306. C<$optional_condition>
  10307.  
  10308. =item has_child ($optional_condition)
  10309.  
  10310. Return the first child of the element, or the first child matching the 
  10311. C<$optional_condition> (same as L<first_child>)
  10312.  
  10313. =item has_children ($optional_condition)
  10314.  
  10315. Return the first child of the element, or the first child matching the 
  10316. C<$optional_condition> (same as L<first_child>)
  10317.  
  10318.  
  10319. =item first_child_text   ($optional_condition)
  10320.  
  10321. Return the text of the first child of the element, or the first child
  10322.  matching the C<$optional_condition>
  10323. If there is no first_child then returns ''. This avoids getting the
  10324. child, checking for its existence then getting the text for trivial cases.
  10325.  
  10326. Similar methods are available for the other navigation methods: 
  10327.  
  10328. =over 4
  10329.  
  10330. =item last_child_text
  10331.  
  10332. =item prev_sibling_text
  10333.  
  10334. =item next_sibling_text
  10335.  
  10336. =item prev_elt_text
  10337.  
  10338. =item next_elt_text
  10339.  
  10340. =item child_text
  10341.  
  10342. =item parent_text
  10343.  
  10344. =back
  10345.  
  10346. All this methods also exist in "trimmed" variant: 
  10347.  
  10348. =over 4
  10349.  
  10350. =item first_child_trimmed_text
  10351.  
  10352. =item last_child_trimmed_text
  10353.  
  10354. =item prev_sibling_trimmed_text
  10355.  
  10356. =item next_sibling_trimmed_text
  10357.  
  10358. =item prev_elt_trimmed_text
  10359.  
  10360. =item next_elt_trimmed_text
  10361.  
  10362. =item child_trimmed_text
  10363.  
  10364. =item parent_trimmed_text
  10365.  
  10366. =back
  10367.  
  10368. =item field         ($optional_condition)
  10369.  
  10370. Same method as C<first_child_text> with a different name
  10371.  
  10372. =item trimmed_field         ($optional_condition)
  10373.  
  10374. Same method as C<first_child_trimmed_text> with a different name
  10375.  
  10376. =item set_field ($condition, $optional_atts, @list_of_elt_and_strings)
  10377.  
  10378. Set the content of the first child of the element that matches
  10379. C<$condition>, the rest of the arguments is tha same as for C<L<set_content>>
  10380.  
  10381. If no child matches C<$condition> _and_ if C<$condition> is a valid
  10382. XML element name, then a new element by that name is created and 
  10383. inserted as the last child.
  10384.  
  10385. =item first_child_matches   ($optional_condition)
  10386.  
  10387. Return the element if the first child of the element (if it exists) passes
  10388. the C<$optional_condition> C<undef> otherwise
  10389.  
  10390.   if( $elt->first_child_matches( 'title')) ... 
  10391.  
  10392. is equivalent to
  10393.  
  10394.   if( $elt->{first_child} && $elt->{first_child}->passes( 'title')) 
  10395.  
  10396. C<first_child_is> is an other name for this method
  10397.  
  10398. Similar methods are available for the other navigation methods: 
  10399.  
  10400. =over 4
  10401.  
  10402. =item last_child_matches
  10403.  
  10404. =item prev_sibling_matches
  10405.  
  10406. =item next_sibling_matches
  10407.  
  10408. =item prev_elt_matches
  10409.  
  10410. =item next_elt_matches
  10411.  
  10412. =item child_matches
  10413.  
  10414. =item parent_matches
  10415.  
  10416. =back
  10417.  
  10418. =item is_first_child ($optional_condition)
  10419.  
  10420. returns true (the element) if the element is the first child of its parent
  10421. (optionaly that satisfies the C<$optional_condition>)
  10422.  
  10423. =item is_last_child ($optional_condition)
  10424.  
  10425. returns true (the element) if the element is the first child of its parent
  10426. (optionaly that satisfies the C<$optional_condition>)
  10427.  
  10428. =item prev_sibling  ($optional_condition)
  10429.  
  10430. Return the previous sibling of the element, or the previous sibling matching
  10431. C<$optional_condition>
  10432.  
  10433. =item next_sibling  ($optional_condition)
  10434.  
  10435. Return the next sibling of the element, or the first one matching 
  10436. C<$optional_condition>.
  10437.  
  10438. =item next_elt     ($optional_elt, $optional_condition)
  10439.  
  10440. Return the next elt (optionally matching C<$optional_condition>) of the element. This 
  10441. is defined as the next element which opens after the current element opens.
  10442. Which usually means the first child of the element.
  10443. Counter-intuitive as it might look this allows you to loop through the
  10444. whole document by starting from the root.
  10445.  
  10446. The C<$optional_elt> is the root of a subtree. When the C<next_elt> is out of the
  10447. subtree then the method returns undef. You can then walk a sub tree with:
  10448.  
  10449.   my $elt= $subtree_root;
  10450.   while( $elt= $elt->next_elt( $subtree_root)
  10451.     { # insert processing code here
  10452.     }
  10453.  
  10454. =item prev_elt     ($optional_condition)
  10455.  
  10456. Return the previous elt (optionally matching C<$optional_condition>) of the
  10457. element. This is the first element which opens before the current one.
  10458. It is usually either the last descendant of the previous sibling or
  10459. simply the parent
  10460.  
  10461. =item next_n_elt   ($offset, $optional_condition)
  10462.  
  10463. Return the C<$offset>-th element that matches the C<$optional_condition> 
  10464.  
  10465. =item following_elt
  10466.  
  10467. Return the following element (as per the XPath following axis)
  10468.  
  10469. =item preceding_elt
  10470.  
  10471. Return the preceding element (as per the XPath preceding axis)
  10472.  
  10473. =item following_elts
  10474.  
  10475. Return the list of following elements (as per the XPath following axis)
  10476.  
  10477. =item preceding_elts
  10478.  
  10479. Return the pst of preceding elements (as per the XPath preceding axis)
  10480.  
  10481. =item children     ($optional_condition)
  10482.  
  10483. Return the list of children (optionally which matches C<$optional_condition>) of 
  10484. the element. The list is in document order.
  10485.  
  10486. =item children_count ($optional_condition)
  10487.  
  10488. Return the number of children of the element (optionally which matches 
  10489. C<$optional_condition>)
  10490.  
  10491. =item children_text ($optional_condition)
  10492.  
  10493. Return an array containing the text of children of the element (optionally 
  10494. which matches C<$optional_condition>)
  10495.  
  10496. =item children_trimmed_text ($optional_condition)
  10497.  
  10498. Return an array containing the trimmed text of children of the element (optionally 
  10499. which matches C<$optional_condition>)
  10500.  
  10501.  
  10502. =item children_copy ($optional_condition)
  10503.  
  10504. Return a list of elements that are copies of the children of the element, 
  10505. optionally which matches C<$optional_condition>
  10506.  
  10507. =item descendants     ($optional_condition)
  10508.  
  10509. Return the list of all descendants (optionally which matches 
  10510. C<$optional_condition>) of the element. This is the equivalent of the 
  10511. C<getElementsByTagName> of the DOM (by the way, if you are really a DOM 
  10512. addict, you can use C<getElementsByTagName> instead)
  10513.  
  10514. =item getElementsByTagName ($optional_condition)
  10515.  
  10516. Same as C<L<descendants>>
  10517.  
  10518. =item find_by_tag_name ($optional_condition)
  10519.  
  10520. Same as C<L<descendants>>
  10521.  
  10522. =item descendants_or_self ($optional_condition)
  10523.  
  10524. Same as C<L<descendants>> except that the element itself is included in the list
  10525. if it matches the C<$optional_condition> 
  10526.  
  10527. =item first_descendant  ($optional_condition)
  10528.  
  10529. Return the first descendant of the element that matches the condition  
  10530.  
  10531. =item last_descendant  ($optional_condition)
  10532.  
  10533. Return the last descendant of the element that matches the condition  
  10534.  
  10535. =item ancestors    ($optional_condition)
  10536.  
  10537. Return the list of ancestors (optionally matching C<$optional_condition>) of the 
  10538. element.  The list is ordered from the innermost ancestor to the outtermost one
  10539.  
  10540. NOTE: the element itself is not part of the list, in order to include it 
  10541. you will have to use ancestors_or_self
  10542.  
  10543. =item ancestors_or_self     ($optional_condition)
  10544.  
  10545. Return the list of ancestors (optionally matching C<$optional_condition>) of the 
  10546. element, including the element (if it matches the condition>).  
  10547. The list is ordered from the innermost ancestor to the outtermost one
  10548.  
  10549. =item passes ($condition)
  10550.  
  10551. Return the element if it passes the C<$condition> 
  10552.  
  10553. =item att          ($att)
  10554.  
  10555. Return the value of attribute C<$att> or C<undef>
  10556.  
  10557. =item set_att      ($att, $att_value)
  10558.  
  10559. Set the attribute of the element to the given value
  10560.  
  10561. You can actually set several attributes this way:
  10562.  
  10563.   $elt->set_att( att1 => "val1", att2 => "val2");
  10564.  
  10565. =item del_att      ($att)
  10566.  
  10567. Delete the attribute for the element
  10568.  
  10569. You can actually delete several attributes at once:
  10570.  
  10571.   $elt->del_att( 'att1', 'att2', 'att3');
  10572.  
  10573. =item cut
  10574.  
  10575. Cut the element from the tree. The element still exists, it can be copied
  10576. or pasted somewhere else, it is just not attached to the tree anymore.
  10577.  
  10578. Note that the "old" links to the parent, previous and next siblings can
  10579. still be accessed using the former_* methods
  10580.  
  10581. =item former_next_sibling
  10582.  
  10583. Returns the former next sibling of a cut node (or undef if the node has not been cut)
  10584.  
  10585. This makes it easier to write loops where you cut elements:
  10586.  
  10587.     my $child= $parent->first_child( 'achild');
  10588.     while( $child->{'att'}->{'cut'}) 
  10589.       { $child->cut; $child= $child->former_next_sibling; }
  10590.  
  10591. =item former_prev_sibling
  10592.  
  10593. Returns the former previous sibling of a cut node (or undef if the node has not been cut)
  10594.  
  10595. =item former_parent
  10596.  
  10597. Returns the former parent of a cut node (or undef if the node has not been cut)
  10598.  
  10599. =item cut_children ($optional_condition)
  10600.  
  10601. Cut all the children of the element (or all of those which satisfy the
  10602. C<$optional_condition>).
  10603.  
  10604. Return the list of children 
  10605.  
  10606. =item copy        ($elt)
  10607.  
  10608. Return a copy of the element. The copy is a "deep" copy: all sub elements of 
  10609. the element are duplicated.
  10610.  
  10611. =item paste       ($optional_position, $ref)
  10612.  
  10613. Paste a (previously C<cut> or newly generated) element. Die if the element
  10614. already belongs to a tree.
  10615.  
  10616. Note that the calling element is pasted:
  10617.  
  10618.   $child->paste( first_child => $existing_parent);
  10619.   $new_sibling->paste( after => $this_sibling_is_already_in_the_tree);
  10620.  
  10621. or
  10622.  
  10623.   my $new_elt= XML::Twig::Elt->new( tag => $content);
  10624.   $new_elt->paste( $position => $existing_elt);
  10625.  
  10626. Example:
  10627.  
  10628.   my $t= XML::Twig->new->parse( 'doc.xml')
  10629.   my $toc= $t->root->new( 'toc');
  10630.   $toc->paste( $t->root); # $toc is pasted as first child of the root 
  10631.   foreach my $title ($t->findnodes( '/doc/section/title'))
  10632.     { my $title_toc= $title->copy;
  10633.       # paste $title_toc as the last child of toc
  10634.       $title_toc->paste( last_child => $toc) 
  10635.     }
  10636.  
  10637. Position options:
  10638.  
  10639. =over 4
  10640.  
  10641. =item first_child (default)
  10642.  
  10643. The element is pasted as the first child of C<$ref>
  10644.  
  10645. =item last_child
  10646.  
  10647. The element is pasted as the last child of C<$ref>
  10648.  
  10649. =item before
  10650.  
  10651. The element is pasted before C<$ref>, as its previous sibling.
  10652.  
  10653. =item after
  10654.  
  10655. The element is pasted after C<$ref>, as its next sibling.
  10656.  
  10657. =item within
  10658.  
  10659. In this case an extra argument, C<$offset>, should be supplied. The element
  10660. will be pasted in the reference element (or in its first text child) at the
  10661. given offset. To achieve this the reference element will be split at the 
  10662. offset.
  10663.  
  10664. =back
  10665.  
  10666. Note that you can call directly the underlying method:
  10667.  
  10668. =over 4
  10669.  
  10670. =item paste_before
  10671.  
  10672. =item paste_after
  10673.  
  10674. =item paste_first_child
  10675.  
  10676. =item paste_last_child
  10677.  
  10678. =item paste_within
  10679.  
  10680. =back
  10681.  
  10682. =item move       ($optional_position, $ref)
  10683.  
  10684. Move an element in the tree.
  10685. This is just a C<cut> then a C<paste>.  The syntax is the same as C<paste>.
  10686.  
  10687. =item replace       ($ref)
  10688.  
  10689. Replaces an element in the tree. Sometimes it is just not possible toC<cut> 
  10690. an element then C<paste> another in its place, so C<replace> comes in handy.
  10691. The calling element replaces C<$ref>.
  10692.  
  10693. =item replace_with   (@elts)
  10694.  
  10695. Replaces the calling element with one or more elements 
  10696.  
  10697. =item delete
  10698.  
  10699. Cut the element and frees the memory.
  10700.  
  10701. =item prefix       ($text, $optional_option)
  10702.  
  10703. Add a prefix to an element. If the element is a C<PCDATA> element the text
  10704. is added to the pcdata, if the elements first child is a C<PCDATA> then the
  10705. text is added to it's pcdata, otherwise a new C<PCDATA> element is created 
  10706. and pasted as the first child of the element.
  10707.  
  10708. If the option is C<asis> then the prefix is added asis: it is created in
  10709. a separate C<PCDATA> element with an C<asis> property. You can then write:
  10710.  
  10711.   $elt1->prefix( '<b>', 'asis');
  10712.  
  10713. to create a C<< <b> >> in the output of C<print>.
  10714.  
  10715. =item suffix       ($text, $optional_option)
  10716.  
  10717. Add a suffix to an element. If the element is a C<PCDATA> element the text
  10718. is added to the pcdata, if the elements last child is a C<PCDATA> then the
  10719. text is added to it's pcdata, otherwise a new PCDATA element is created 
  10720. and pasted as the last child of the element.
  10721.  
  10722. If the option is C<asis> then the suffix is added asis: it is created in
  10723. a separate C<PCDATA> element with an C<asis> property. You can then write:
  10724.  
  10725.   $elt2->suffix( '</b>', 'asis');
  10726.  
  10727. =item trim
  10728.  
  10729. Trim the element in-place: spaces at the beginning and at the end of the element
  10730. are discarded and multiple spaces within the element (or its descendants) are 
  10731. replaced by a single space.
  10732.  
  10733. Note that in some cases you can still end up with multiple spaces, if they are
  10734. split between several elements:
  10735.  
  10736.   <doc>  text <b>  hah! </b>  yep</doc>
  10737.  
  10738. gets trimmed to
  10739.  
  10740.   <doc>text <b> hah! </b> yep</doc>
  10741.  
  10742. This is somewhere in between a bug and a feature.
  10743.  
  10744.  
  10745. =item simplify (%options)
  10746.  
  10747. Return a data structure suspiciously similar to XML::Simple's. Options are
  10748. identical to XMLin options, see XML::Simple doc for more details (or use
  10749. DATA::dumper or YAML to dump the data structure)
  10750.  
  10751. =over 4
  10752.  
  10753. =item content_key
  10754.  
  10755. =item forcearray 
  10756.                              
  10757. =item keyattr 
  10758.  
  10759. =item noattr 
  10760.  
  10761. =item normalize_space
  10762.  
  10763. aka normalise_space
  10764.  
  10765. =item variables (%var_hash)
  10766.  
  10767. %var_hash is a hash { name => value }
  10768.  
  10769. This option allows variables in the XML to be expanded when the file is read. (there is no facility for putting the variable names back if you regenerate XML using XMLout).
  10770.  
  10771. A 'variable' is any text of the form ${name} (or $name) which occurs in an attribute value or in the text content of an element. If 'name' matches a key in the supplied hashref, ${name} will be replaced with the corresponding value from the hashref. If no matching key is found, the variable will not be replaced. 
  10772.  
  10773. =item var_att ($attribute_name)
  10774.  
  10775. This option gives the name of an attribute that will be used to create 
  10776. variables in the XML:
  10777.  
  10778.   <dirs>
  10779.     <dir name="prefix">/usr/local</dir>
  10780.     <dir name="exec_prefix">$prefix/bin</dir>
  10781.   </dirs>
  10782.  
  10783. use C<< var => 'name' >> to get $prefix replaced by /usr/local in the
  10784. generated data structure  
  10785.  
  10786. By default variables are captured by the following regexp: /$(\w+)/
  10787.     
  10788. =item var_regexp (regexp)
  10789.  
  10790. This option changes the regexp used to capture variables. The variable
  10791. name should be in $1
  10792.  
  10793. =item group_tags { grouping tag => grouped tag, grouping tag 2 => grouped tag 2...}
  10794.  
  10795. Option used to simplify the structure: elements listed will not be used.
  10796. Their children will be, they will be considered children of the element
  10797. parent.
  10798.  
  10799. If the element is:
  10800.  
  10801.   <config host="laptop.xmltwig.com">
  10802.     <server>localhost</server>
  10803.     <dirs>
  10804.       <dir name="base">/home/mrodrigu/standards</dir>
  10805.       <dir name="tools">$base/tools</dir>
  10806.     </dirs>
  10807.     <templates>
  10808.       <template name="std_def">std_def.templ</template>
  10809.       <template name="dummy">dummy</template>
  10810.     </templates>
  10811.   </config>
  10812.  
  10813. Then calling simplify with C<< group_tags => { dirs => 'dir',
  10814. templates => 'template'} >>
  10815. makes the data structure be exactly as if the start and end tags for C<dirs> and
  10816. C<templates> were not there.
  10817.  
  10818. A YAML dump of the structure 
  10819.  
  10820.   base: '/home/mrodrigu/standards'
  10821.   host: laptop.xmltwig.com
  10822.   server: localhost
  10823.   template:
  10824.     - std_def.templ
  10825.     - dummy.templ
  10826.   tools: '$base/tools'
  10827.  
  10828.  
  10829. =back
  10830.  
  10831. =item split_at        ($offset)
  10832.  
  10833. Split a text (C<PCDATA> or C<CDATA>) element in 2 at C<$offset>, the original
  10834. element now holds the first part of the string and a new element holds the
  10835. right part. The new element is returned
  10836.  
  10837. If the element is not a text element then the first text child of the element
  10838. is split
  10839.  
  10840. =item split        ( $optional_regexp, $tag1, $atts1, $tag2, $atts2...)
  10841.  
  10842. Split the text descendants of an element in place, the text is split using 
  10843. the C<$regexp>, if the regexp includes () then the matched separators will be 
  10844. wrapped in elements.  C<$1> is wrapped in $tag1, with attributes C<$atts1> if
  10845. C<$atts1> is given (as a hashref), C<$2> is wrapped in $tag2... 
  10846.  
  10847. if $elt is C<< <p>tati tata <b>tutu tati titi</b> tata tati tata</p> >>
  10848.  
  10849.   $elt->split( qr/(ta)ti/, 'foo', {type => 'toto'} )
  10850.  
  10851. will change $elt to
  10852.  
  10853.   <p><foo type="toto">ta</foo> tata <b>tutu <foo type="toto">ta</foo>
  10854.       titi</b> tata <foo type="toto">ta</foo> tata</p> 
  10855.  
  10856. The regexp can be passed either as a string or as C<qr//> (perl 5.005 and 
  10857. later), it defaults to \s+ just as the C<split> built-in (but this would be 
  10858. quite a useless behaviour without the C<$optional_tag> parameter)
  10859.  
  10860. C<$optional_tag> defaults to PCDATA or CDATA, depending on the initial element
  10861. type
  10862.  
  10863. The list of descendants is returned (including un-touched original elements 
  10864. and newly created ones)
  10865.  
  10866. =item mark        ( $regexp, $optional_tag, $optional_attribute_ref)
  10867.  
  10868. This method behaves exactly as L<split|split>, except only the newly created 
  10869. elements are returned
  10870.  
  10871. =item wrap_children ( $regexp_string, $tag, $optional_attribute_hashref)
  10872.  
  10873. Wrap the children of the element that match the regexp in an element C<$tag>.
  10874. If $optional_attribute_hashref is passed then the new element will
  10875. have these attributes.
  10876.  
  10877. The $regexp_string includes tags, within pointy brackets, as in 
  10878. C<< <title><para>+ >> and the usual Perl modifiers (+*?...). 
  10879. Tags can be further qualified with attributes:
  10880. C<< <para type="warning" classif="cosmic_secret">+ >>. The values
  10881. for attributes should be xml-escaped: C<< <candy type="M&Ms">* >>
  10882. (C<E<lt>>, C<&> B<C<E<gt>>> and C<"> should be escaped). 
  10883.  
  10884. Note that elements might get extra C<id> attributes in the process. See L<add_id>.
  10885. Use L<strip_att> to remove unwanted id's. 
  10886.  
  10887. Here is an example:
  10888.  
  10889. If the element C<$elt> has the following content:
  10890.  
  10891.   <elt>
  10892.    <p>para 1</p>
  10893.    <l_l1_1>list 1 item 1 para 1</l_l1_1>
  10894.      <l_l1>list 1 item 1 para 2</l_l1>
  10895.    <l_l1_n>list 1 item 2 para 1 (only para)</l_l1_n>
  10896.    <l_l1_n>list 1 item 3 para 1</l_l1_n>
  10897.      <l_l1>list 1 item 3 para 2</l_l1>
  10898.      <l_l1>list 1 item 3 para 3</l_l1>
  10899.    <l_l1_1>list 2 item 1 para 1</l_l1_1>
  10900.      <l_l1>list 2 item 1 para 2</l_l1>
  10901.    <l_l1_n>list 2 item 2 para 1 (only para)</l_l1_n>
  10902.    <l_l1_n>list 2 item 3 para 1</l_l1_n>
  10903.      <l_l1>list 2 item 3 para 2</l_l1>
  10904.      <l_l1>list 2 item 3 para 3</l_l1>
  10905.   </elt>
  10906.  
  10907. Then the code
  10908.  
  10909.   $elt->wrap_children( q{<l_l1_1><l_l1>*} , li => { type => "ul1" });
  10910.   $elt->wrap_children( q{<l_l1_n><l_l1>*} , li => { type => "ul" });
  10911.  
  10912.   $elt->wrap_children( q{<li type="ul1"><li type="ul">+}, "ul");
  10913.   $elt->strip_att( 'id');
  10914.   $elt->strip_att( 'type');
  10915.   $elt->print;
  10916.  
  10917. will output:
  10918.  
  10919.   <elt>
  10920.      <p>para 1</p>
  10921.      <ul>
  10922.        <li>
  10923.          <l_l1_1>list 1 item 1 para 1</l_l1_1>
  10924.          <l_l1>list 1 item 1 para 2</l_l1>
  10925.        </li>
  10926.        <li>
  10927.          <l_l1_n>list 1 item 2 para 1 (only para)</l_l1_n>
  10928.        </li>
  10929.        <li>
  10930.          <l_l1_n>list 1 item 3 para 1</l_l1_n>
  10931.          <l_l1>list 1 item 3 para 2</l_l1>
  10932.          <l_l1>list 1 item 3 para 3</l_l1>
  10933.        </li>
  10934.      </ul>
  10935.      <ul>
  10936.        <li>
  10937.          <l_l1_1>list 2 item 1 para 1</l_l1_1>
  10938.          <l_l1>list 2 item 1 para 2</l_l1>
  10939.        </li>
  10940.        <li>
  10941.          <l_l1_n>list 2 item 2 para 1 (only para)</l_l1_n>
  10942.        </li>
  10943.        <li>
  10944.          <l_l1_n>list 2 item 3 para 1</l_l1_n>
  10945.          <l_l1>list 2 item 3 para 2</l_l1>
  10946.          <l_l1>list 2 item 3 para 3</l_l1>
  10947.        </li>
  10948.      </ul>
  10949.   </elt>
  10950.  
  10951. =item subs_text ($regexp, $replace)
  10952.  
  10953. subs_text does text substitution, similar to perl's C< s///> operator.
  10954.  
  10955. C<$regexp> must be a perl regexp, created with the C<qr> operatot.
  10956.  
  10957. C<$replace> can include C<$1, $2>... from the C<$regexp>. It can also be
  10958. used to create element and entities, by using 
  10959. C<< &elt( tag => { att => val }, text) >> (similar syntax as C<L<new>>) and
  10960. C<< &ent( name) >>.
  10961.  
  10962. Here is a rather complex example:
  10963.  
  10964.   $elt->subs_text( qr{(?<!do not )link to (http://([^\s,]*))},
  10965.                    'see &elt( a =>{ href => $1 }, $2)'
  10966.                  );
  10967.  
  10968. This will replace text like I<link to http://www.xmltwig.com> by 
  10969. I<< see <a href="www.xmltwig.com">www.xmltwig.com</a> >>, but not
  10970. I<do not link to...>
  10971.  
  10972. Generating entities (here replacing spaces with  ):
  10973.  
  10974.   $elt->subs_text( qr{ }, '&ent( " ")');
  10975.  
  10976. or, using a variable:
  10977.  
  10978.   my $ent=" ";
  10979.   $elt->subs_text( qr{ }, "&ent( '$ent')");
  10980.  
  10981. Note that the substitution is always global, as in using the C<g> modifier
  10982. in a perl substitution, and that it is performed on all text descendants
  10983. of the element.
  10984.  
  10985. B<Bug>: in the C<$regexp>, you can only use C<\1>, C<\2>... if the replacement
  10986. expression does not include elements or attributes. eg
  10987.  
  10988.   t->subs_text( qr/((t[aiou])\2)/, '$2');             # ok, replaces toto, tata, titi, tutu by to, ta, ti, tu
  10989.   t->subs_text( qr/((t[aiou])\2)/, '&elt(p => $1)' ); # NOK, does not find toto...
  10990.  
  10991. =item add_id
  10992.  
  10993. Add an id to the element.
  10994.  
  10995. The id is an attribute (C<id> by default, see the C<id> option for XML::Twig
  10996. C<new> to change it. Use an id starting with C<#> to get an id that's not 
  10997. output by L<print>, L<flush> or L<sprint>) that allows you to use the
  10998. L<elt_id> method to get the element easily.
  10999.  
  11000. =item set_id_seed ($prefix)
  11001.  
  11002. by default the id generated by C<L<add_id>> is C<< twig_id_<nnnn> >>, 
  11003. C<set_id_seed> changes the prefix to C<$prefix> and resets the number
  11004. to 1
  11005.  
  11006. =item strip_att ($att)
  11007.  
  11008. Remove the attribute C<$att> from all descendants of the element (including 
  11009. the element)
  11010.  
  11011. Return the element
  11012.  
  11013. =item change_att_name ($old_name, $new_name)
  11014.  
  11015. Change the name of the attribute from C<$old_name> to C<$new_name>. If there is no
  11016. attribute C<$old_name> nothing happens.
  11017.  
  11018. =item sort_children_on_value( %options)
  11019.  
  11020. Sort the children of the element in place according to their text.
  11021. All children are sorted. 
  11022.  
  11023. Return the element, with its children sorted.
  11024.  
  11025.  
  11026. L<%options> are
  11027.  
  11028.   type  : numeric |  alpha     (default: alpha)
  11029.   order : normal  |  reverse   (default: normal)
  11030.  
  11031. Return the element, with its children sorted
  11032.  
  11033.  
  11034. =item sort_children_on_att ($att, %options)
  11035.  
  11036. Sort the children of the  element in place according to attribute C<$att>. 
  11037. C<%options> are the same as for L<C<sort_children_on_value>>
  11038.  
  11039. Return the element.
  11040.  
  11041.  
  11042. =item sort_children_on_field ($tag, %options)
  11043.  
  11044. Sort the children of the element in place, according to the field C<$tag> (the 
  11045. text of the first child of the child with this tag). C<%options> are the same
  11046. as for L<C<sort_children_on_value>>.
  11047.  
  11048. Return the element, with its children sorted
  11049.  
  11050.  
  11051. =item sort_children( $get_key, %options) 
  11052.  
  11053. Sort the children of the element in place. The C<$get_key> argument is
  11054. a reference to a function that returns the sort key when passed an element.
  11055.  
  11056. For example:
  11057.  
  11058.   $elt->sort_children( sub { $_[0]->{'att'}->{"nb"} + $_[0]->text }, 
  11059.                        type => 'numeric', order => 'reverse'
  11060.                      );
  11061.  
  11062. =item field_to_att ($cond, $att)
  11063.  
  11064. Turn the text of the first sub-element matched by C<$cond> into the value of 
  11065. attribute C<$att> of the element. If C<$att> is ommited then C<$cond> is used 
  11066. as the name of the attribute, which makes sense only if C<$cond> is a valid
  11067. element (and attribute) name.
  11068.  
  11069. The sub-element is then cut.
  11070.  
  11071. =item att_to_field ($att, $tag)
  11072.  
  11073. Take the value of attribute C<$att> and create a sub-element C<$tag> as first
  11074. child of the element. If C<$tag> is ommited then C<$att> is used as the name of
  11075. the sub-element. 
  11076.  
  11077.  
  11078. =item get_xpath  ($xpath, $optional_offset)
  11079.  
  11080. Return a list of elements satisfying the C<$xpath>. C<$xpath> is an XPATH-like 
  11081. expression.
  11082.  
  11083. A subset of the XPATH abbreviated syntax is covered:
  11084.  
  11085.   tag
  11086.   tag[1] (or any other positive number)
  11087.   tag[last()]
  11088.   tag[@att] (the attribute exists for the element)
  11089.   tag[@att="val"]
  11090.   tag[@att=~ /regexp/]
  11091.   tag[att1="val1" and att2="val2"]
  11092.   tag[att1="val1" or att2="val2"]
  11093.   tag[string()="toto"] (returns tag elements which text (as per the text method) 
  11094.                        is toto)
  11095.   tag[string()=~/regexp/] (returns tag elements which text (as per the text 
  11096.                           method) matches regexp)
  11097.   expressions can start with / (search starts at the document root)
  11098.   expressions can start with . (search starts at the current element)
  11099.   // can be used to get all descendants instead of just direct children
  11100.   * matches any tag
  11101.   
  11102. So the following examples from the 
  11103. F<XPath recommendationL<http://www.w3.org/TR/xpath.html#path-abbrev>> work:
  11104.  
  11105.   para selects the para element children of the context node
  11106.   * selects all element children of the context node
  11107.   para[1] selects the first para child of the context node
  11108.   para[last()] selects the last para child of the context node
  11109.   */para selects all para grandchildren of the context node
  11110.   /doc/chapter[5]/section[2] selects the second section of the fifth chapter 
  11111.      of the doc 
  11112.   chapter//para selects the para element descendants of the chapter element 
  11113.      children of the context node
  11114.   //para selects all the para descendants of the document root and thus selects
  11115.      all para elements in the same document as the context node
  11116.   //olist/item selects all the item elements in the same document as the 
  11117.      context node that have an olist parent
  11118.   .//para selects the para element descendants of the context node
  11119.   .. selects the parent of the context node
  11120.   para[@type="warning"] selects all para children of the context node that have
  11121.      a type attribute with value warning 
  11122.   employee[@secretary and @assistant] selects all the employee children of the
  11123.      context node that have both a secretary attribute and an assistant 
  11124.      attribute
  11125.  
  11126.  
  11127. The elements will be returned in the document order.
  11128.  
  11129. If C<$optional_offset> is used then only one element will be returned, the one 
  11130. with the appropriate offset in the list, starting at 0
  11131.  
  11132. Quoting and interpolating variables can be a pain when the Perl syntax and the 
  11133. XPATH syntax collide, so use alternate quoting mechanisms like q or qq 
  11134. (I like q{} and qq{} myself).
  11135.  
  11136. Here are some more examples to get you started:
  11137.  
  11138.   my $p1= "p1";
  11139.   my $p2= "p2";
  11140.   my @res= $t->get_xpath( qq{p[string( "$p1") or string( "$p2")]});
  11141.  
  11142.   my $a= "a1";
  11143.   my @res= $t->get_xpath( qq{//*[@att="$a"]});
  11144.  
  11145.   my $val= "a1";
  11146.   my $exp= qq{//p[ \@att='$val']}; # you need to use \@ or you will get a warning
  11147.   my @res= $t->get_xpath( $exp);
  11148.  
  11149. Note that the only supported regexps delimiters are / and that you must 
  11150. backslash all / in regexps AND in regular strings.
  11151.  
  11152. XML::Twig does not provide natively full XPATH support, but you can use 
  11153. C<L<XML::Twig::XPath>> to get C<findnodes> to use C<XML::XPath> as the
  11154. XPath engine, with full coverage of the spec.
  11155.  
  11156. C<L<XML::Twig::XPath>> to get C<findnodes> to use C<XML::XPath> as the
  11157. XPath engine, with full coverage of the spec.
  11158.  
  11159. =item find_nodes
  11160.  
  11161. same asC<get_xpath> 
  11162.  
  11163. =item findnodes
  11164.  
  11165. same asC<get_xpath> 
  11166.  
  11167.  
  11168. =item text
  11169.  
  11170. Return a string consisting of all the C<PCDATA> and C<CDATA> in an element, 
  11171. without any tags. The text is not XML-escaped: base entities such as C<&> 
  11172. and C<< < >> are not escaped.
  11173.  
  11174. =item trimmed_text
  11175.  
  11176. Same as C<text> except that the text is trimmed: leading and trailing spaces
  11177. are discarded, consecutive spaces are collapsed
  11178.  
  11179. =item set_text        ($string)
  11180.  
  11181. Set the text for the element: if the element is a C<PCDATA>, just set its
  11182. text, otherwise cut all the children of the element and create a single
  11183. C<PCDATA> child for it, which holds the text.
  11184.  
  11185. =item merge ($elt2)
  11186.  
  11187. Move the content of C<$elt2> within the element
  11188.  
  11189. =item insert         ($tag1, [$optional_atts1], $tag2, [$optional_atts2],...)
  11190.  
  11191. For each tag in the list inserts an element C<$tag> as the only child of the 
  11192. element.  The element gets the optional attributes inC<< $optional_atts<n>. >> 
  11193. All children of the element are set as children of the new element.
  11194. The upper level element is returned.
  11195.  
  11196.   $p->insert( table => { border=> 1}, 'tr', 'td') 
  11197.  
  11198. put C<$p> in a table with a visible border, a single C<tr> and a single C<td> 
  11199. and return the C<table> element:
  11200.  
  11201.   <p><table border="1"><tr><td>original content of p</td></tr></table></p>
  11202.  
  11203. =item wrap_in        (@tag)
  11204.  
  11205. Wrap elements in C<@tag> as the successive ancestors of the element, returns the 
  11206. new element.
  11207. C<< $elt->wrap_in( 'td', 'tr', 'table') >> wraps the element as a single cell in a 
  11208. table for example.
  11209.  
  11210. Optionally each tag can be followed by a hasref of attributes, that will be 
  11211. set on the wrapping element:
  11212.  
  11213.   $elt->wrap_in( p => { class => "advisory" }, div => { class => "intro", id => "div_intro });
  11214.  
  11215. =item insert_new_elt ($opt_position, $tag, $opt_atts_hashref, @opt_content)
  11216.  
  11217. Combines a C<L<new|new> > and a C<L<paste|paste> >: creates a new element using 
  11218. C<$tag>, C<$opt_atts_hashref >and C<@opt_content> which are arguments similar 
  11219. to those for C<new>, then paste it, using C<$opt_position> or C<'first_child'>,
  11220. relative to C<$elt>.
  11221.  
  11222. Return the newly created element
  11223.  
  11224. =item erase
  11225.  
  11226. Erase the element: the element is deleted and all of its children are
  11227. pasted in its place.
  11228.  
  11229. =item set_content    ( $optional_atts, @list_of_elt_and_strings)
  11230.                      ( $optional_atts, '#EMPTY')
  11231.  
  11232. Set the content for the element, from a list of strings and
  11233. elements.  Cuts all the element children, then pastes the list
  11234. elements as the children.  This method will create a C<PCDATA> element
  11235. for any strings in the list.
  11236.  
  11237. The C<$optional_atts> argument is the ref of a hash of attributes. If this
  11238. argument is used then the previous attributes are deleted, otherwise they
  11239. are left untouched. 
  11240.  
  11241. B<WARNING>: if you rely on ID's then you will have to set the id yourself. At
  11242. this point the element does not belong to a twig yet, so the ID attribute
  11243. is not known so it won't be strored in the ID list.
  11244.  
  11245. A content of 'C<#EMPTY>' creates an empty element;
  11246.  
  11247. =item namespace ($optional_prefix)
  11248.  
  11249. Return the URI of the namespace that C<$optional_prefix> or the element name
  11250. belongs to. If the name doesn't belong to any namespace, C<undef> is returned.
  11251.  
  11252. =item local_name
  11253.  
  11254. Return the local name (without the prefix) for the element
  11255.  
  11256. =item ns_prefix
  11257.  
  11258. Return the namespace prefix for the element
  11259.  
  11260. =item current_ns_prefixes
  11261.  
  11262. Returna list of namespace prefixes valid for the element. The order of the
  11263. prefixes in the list has no meaning. If the default namespace is currently 
  11264. bound, '' appears in the list.
  11265.  
  11266.  
  11267. =item inherit_att  ($att, @optional_tag_list)
  11268.  
  11269. Return the value of an attribute inherited from parent tags. The value
  11270. returned is found by looking for the attribute in the element then in turn
  11271. in each of its ancestors. If the C<@optional_tag_list> is supplied only those
  11272. ancestors whose tag is in the list will be checked. 
  11273.  
  11274. =item all_children_are ($optional_condition)
  11275.  
  11276. return 1 if all children of the element pass the C<$optional_condition>, 
  11277. 0 otherwise
  11278.  
  11279. =item level       ($optional_condition)
  11280.  
  11281. Return the depth of the element in the twig (root is 0).
  11282. If C<$optional_condition> is given then only ancestors that match the condition are 
  11283. counted.
  11284.  
  11285. B<WARNING>: in a tree created using the C<twig_roots> option this will not return
  11286. the level in the document tree, level 0 will be the document root, level 1 
  11287. will be the C<twig_roots> elements. During the parsing (in a C<twig_handler>)
  11288. you can use the C<depth> method on the twig object to get the real parsing depth.
  11289.  
  11290. =item in           ($potential_parent)
  11291.  
  11292. Return true if the element is in the potential_parent (C<$potential_parent> is 
  11293. an element)
  11294.  
  11295. =item in_context   ($cond, $optional_level)
  11296.  
  11297. Return true if the element is included in an element which passes C<$cond>
  11298. optionally within C<$optional_level> levels. The returned value is the 
  11299. including element.
  11300.  
  11301. =item pcdata
  11302.  
  11303. Return the text of a C<PCDATA> element or C<undef> if the element is not 
  11304. C<PCDATA>.
  11305.  
  11306. =item pcdata_xml_string
  11307.  
  11308. Return the text of a PCDATA element or undef if the element is not PCDATA. 
  11309. The text is "XML-escaped" ('&' and '<' are replaced by '&' and '<')
  11310.  
  11311. =item set_pcdata     ($text)
  11312.  
  11313. Set the text of a C<PCDATA> element. 
  11314.  
  11315. =item append_pcdata  ($text)
  11316.  
  11317. Add the text at the end of a C<PCDATA> element.
  11318.  
  11319. =item is_cdata
  11320.  
  11321. Return 1 if the element is a C<CDATA> element, returns 0 otherwise.
  11322.  
  11323. =item is_text
  11324.  
  11325. Return 1 if the element is a C<CDATA> or C<PCDATA> element, returns 0 otherwise.
  11326.  
  11327. =item cdata
  11328.  
  11329. Return the text of a C<CDATA> element or C<undef> if the element is not 
  11330. C<CDATA>.
  11331.  
  11332. =item cdata_string
  11333.  
  11334. Return the XML string of a C<CDATA> element, including the opening and
  11335. closing markers.
  11336.  
  11337. =item set_cdata     ($text)
  11338.  
  11339. Set the text of a C<CDATA> element. 
  11340.  
  11341. =item append_cdata  ($text)
  11342.  
  11343. Add the text at the end of a C<CDATA> element.
  11344.  
  11345. =item remove_cdata
  11346.  
  11347. Turns all C<CDATA> sections in the element into regular C<PCDATA> elements. This is useful
  11348. when converting XML to HTML, as browsers do not support CDATA sections. 
  11349.  
  11350. =item extra_data 
  11351.  
  11352. Return the extra_data (comments and PI's) attached to an element
  11353.  
  11354. =item set_extra_data     ($extra_data)
  11355.  
  11356. Set the extra_data (comments and PI's) attached to an element
  11357.  
  11358. =item append_extra_data  ($extra_data)
  11359.  
  11360. Append extra_data to the existing extra_data before the element (if no
  11361. previous extra_data exists then it is created)
  11362.  
  11363. =item set_asis
  11364.  
  11365. Set a property of the element that causes it to be output without being XML
  11366. escaped by the print functions: if it contains C<< a < b >> it will be output
  11367. as such and not as C<< a < b >>. This can be useful to create text elements
  11368. that will be output as markup. Note that all C<PCDATA> descendants of the 
  11369. element are also marked as having the property (they are the ones taht are
  11370. actually impacted by the change).
  11371.  
  11372. If the element is a C<CDATA> element it will also be output asis, without the
  11373. C<CDATA> markers. The same goes for any C<CDATA> descendant of the element
  11374.  
  11375. =item set_not_asis
  11376.  
  11377. Unsets the C<asis> property for the element and its text descendants.
  11378.  
  11379. =item is_asis
  11380.  
  11381. Return the C<asis> property status of the element ( 1 or C<undef>)
  11382.  
  11383. =item closed                   
  11384.  
  11385. Return true if the element has been closed. Might be usefull if you are
  11386. somewhere in the tree, during the parse, and have no idea whether a parent
  11387. element is completely loaded or not.
  11388.  
  11389. =item get_type
  11390.  
  11391. Return the type of the element: 'C<#ELT>' for "real" elements, or 'C<#PCDATA>',
  11392. 'C<#CDATA>', 'C<#COMMENT>', 'C<#ENT>', 'C<#PI>'
  11393.  
  11394. =item is_elt
  11395.  
  11396. Return the tag if the element is a "real" element, or 0 if it is C<PCDATA>, 
  11397. C<CDATA>...
  11398.  
  11399. =item contains_only_text
  11400.  
  11401. Return 1 if the element does not contain any other "real" element
  11402.  
  11403. =item contains_only ($exp)
  11404.  
  11405. Return the list of children if all children of the element match
  11406. the expression C<$exp> 
  11407.  
  11408.   if( $para->contains_only( 'tt')) { ... }
  11409.  
  11410. =item contains_a_single ($exp)
  11411.  
  11412. If the element contains a single child that matches the expression C<$exp>
  11413. returns that element. Otherwise returns 0.
  11414.  
  11415. =item is_field
  11416.  
  11417. same as C<contains_only_text> 
  11418.  
  11419. =item is_pcdata
  11420.  
  11421. Return 1 if the element is a C<PCDATA> element, returns 0 otherwise.
  11422.  
  11423. =item is_ent
  11424.  
  11425. Return 1 if the element is an entity (an unexpanded entity) element, 
  11426. return 0 otherwise.
  11427.  
  11428. =item is_empty
  11429.  
  11430. Return 1 if the element is empty, 0 otherwise
  11431.  
  11432. =item set_empty
  11433.  
  11434. Flags the element as empty. No further check is made, so if the element
  11435. is actually not empty the output will be messed. The only effect of this 
  11436. method is that the output will be C<< <tag att="value""/> >>.
  11437.  
  11438. =item set_not_empty
  11439.  
  11440. Flags the element as not empty. if it is actually empty then the element will
  11441. be output as C<< <tag att="value""></tag> >>
  11442.  
  11443. =item is_pi
  11444.  
  11445. Return 1 if the element is a processing instruction (C<#PI>) element,
  11446. return 0 otherwise.
  11447.  
  11448. =item target
  11449.  
  11450. Return the target of a processing instruction
  11451.  
  11452. =item set_target ($target)
  11453.  
  11454. Set the target of a processing instruction
  11455.  
  11456. =item data
  11457.  
  11458. Return the data part of a processing instruction
  11459.  
  11460. =item set_data ($data)
  11461.  
  11462. Set the data of a processing instruction
  11463.  
  11464. =item set_pi ($target, $data)
  11465.  
  11466. Set the target and data of a processing instruction
  11467.  
  11468. =item pi_string
  11469.  
  11470. Return the string form of a processing instruction
  11471. (C<< <?target data?> >>)
  11472.  
  11473. =item is_comment
  11474.  
  11475. Return 1 if the element is a comment (C<#COMMENT>) element,
  11476. return 0 otherwise.
  11477.  
  11478. =item set_comment ($comment_text)
  11479.  
  11480. Set the text for a comment
  11481.  
  11482. =item comment
  11483.  
  11484. Return the content of a comment (just the text, not the C<< <!-- >>
  11485. and C<< --> >>)
  11486.  
  11487. =item comment_string 
  11488.  
  11489. Return the XML string for a comment (C<< <!-- comment --> >>)
  11490.  
  11491. =item set_ent ($entity)
  11492.  
  11493. Set an (non-expanded) entity (C<#ENT>). C<$entity>) is the entity
  11494. text (C<&ent;>)
  11495.  
  11496. =item ent
  11497.  
  11498. Return the entity for an entity (C<#ENT>) element (C<&ent;>)
  11499.  
  11500. =item ent_name
  11501.  
  11502. Return the entity name for an entity (C<#ENT>) element (C<ent>)
  11503.  
  11504. =item ent_string
  11505.  
  11506. Return the entity, either expanded if the expanded version is available,
  11507. or non-expanded (C<&ent;>) otherwise
  11508.  
  11509. =item child ($offset, $optional_condition)
  11510.  
  11511. Return the C<$offset>-th child of the element, optionally the C<$offset>-th 
  11512. child that matches C<$optional_condition>. The children are treated as a list, so 
  11513. C<< $elt->child( 0) >> is the first child, while C<< $elt->child( -1) >> is 
  11514. the last child.
  11515.  
  11516. =item child_text ($offset, $optional_condition)
  11517.  
  11518. Return the text of a child or C<undef> if the sibling does not exist. Arguments
  11519. are the same as child.
  11520.  
  11521. =item last_child    ($optional_condition)
  11522.  
  11523. Return the last child of the element, or the last child matching 
  11524. C<$optional_condition> (ie the last of the element children matching
  11525. the condition).
  11526.  
  11527. =item last_child_text   ($optional_condition)
  11528.  
  11529. Same as C<first_child_text> but for the last child.
  11530.  
  11531. =item sibling  ($offset, $optional_condition)
  11532.  
  11533. Return the next or previous C<$offset>-th sibling of the element, or the 
  11534. C<$offset>-th one matching C<$optional_condition>. If C<$offset> is negative then a 
  11535. previous sibling is returned, if $offset is positive then  a next sibling is 
  11536. returned. C<$offset=0> returns the element if there is no condition or
  11537. if the element matches the condition>, C<undef> otherwise.
  11538.  
  11539. =item sibling_text ($offset, $optional_condition)
  11540.  
  11541. Return the text of a sibling or C<undef> if the sibling does not exist. 
  11542. Arguments are the same as C<sibling>.
  11543.  
  11544. =item prev_siblings ($optional_condition)
  11545.  
  11546. Return the list of previous siblings (optionaly matching C<$optional_condition>)
  11547. for the element. The elements are ordered in document order.
  11548.  
  11549. =item next_siblings ($optional_condition)
  11550.  
  11551. Return the list of siblings (optionaly matching C<$optional_condition>)
  11552. following the element. The elements are ordered in document order.
  11553.  
  11554. =item pos ($optional_condition)
  11555.  
  11556. Return the position of the element in the children list. The first child has a
  11557. position of 1 (as in XPath).
  11558.  
  11559. If the C<$optional_condition> is given then only siblings that match the condition 
  11560. are counted. If the element itself does not match the  condition then
  11561. 0 is returned.
  11562.  
  11563. =item atts
  11564.  
  11565. Return a hash ref containing the element attributes
  11566.  
  11567. =item set_atts      ({att1=>$att1_val, att2=> $att2_val... })
  11568.  
  11569. Set the element attributes with the hash ref supplied as the argument
  11570.  
  11571. =item del_atts
  11572.  
  11573. Deletes all the element attributes.
  11574.  
  11575. =item att_nb
  11576.  
  11577. Return the number of attributes for the element
  11578.  
  11579. =item has_atts
  11580.  
  11581. Return true if the element has attributes (in fact return the number of
  11582. attributes, thus being an alias to C<L<att_nb>>
  11583.  
  11584. =item has_no_atts
  11585.  
  11586. Return true if the element has no attributes, false (0) otherwise
  11587.  
  11588. =item att_names
  11589.  
  11590. return a list of the attribute names for the element
  11591.  
  11592. =item att_xml_string ($att, $optional_quote)
  11593.  
  11594. Return the attribute value, where '&', '<' and $quote (" by default)
  11595. are XML-escaped
  11596.  
  11597. if C<$optional_quote> is passed then it is used as the quote.
  11598.  
  11599. =item set_id       ($id)
  11600.  
  11601. Set the C<id> attribute of the element to the value.
  11602. See C<L<elt_id|elt_id> > to change the id attribute name
  11603.  
  11604. =item id
  11605.  
  11606. Gets the id attribute value
  11607.  
  11608. =item del_id       ($id)
  11609.  
  11610. Deletes the C<id> attribute of the element and remove it from the id list
  11611. for the document
  11612.  
  11613. =item class
  11614.  
  11615. Return the C<class> attribute for the element (methods on the C<class>
  11616. attribute are quite convenient when dealing with XHTML, or plain XML that
  11617. will eventually be displayed using CSS)
  11618.  
  11619. =item set_class ($class)
  11620.  
  11621. Set the C<class> attribute for the element to C<$class>
  11622.  
  11623. =item add_to_class ($class)
  11624.  
  11625. Add C<$class> to the element C<class> attribute: the new class is added
  11626. only if it is not already present. Note that classes are sorted alphabetically,
  11627. so the C<class> attribute can be changed even if the class is already there
  11628.  
  11629. =item att_to_class ($att)
  11630.  
  11631. Set the C<class> attribute to the value of attribute C<$att>
  11632.  
  11633. =item add_att_to_class ($att)
  11634.  
  11635. Add the value of attribute C<$att> to the C<class> attribute of the element
  11636.  
  11637. =item move_att_to_class ($att)
  11638.  
  11639. Add the value of attribute C<$att> to the C<class> attribute of the element
  11640. and delete the attribute
  11641.  
  11642. =item tag_to_class
  11643.  
  11644. Set the C<class> attribute of the element to the element tag
  11645.  
  11646. =item add_tag_to_class
  11647.  
  11648. Add the element tag to its C<class> attribute
  11649.  
  11650. =item set_tag_class ($new_tag)
  11651.  
  11652. Add the element tag to its C<class> attribute and sets the tag to C<$new_tag>
  11653.  
  11654. =item in_class ($class)
  11655.  
  11656. Return true (C<1>) if the element is in the class C<$class> (if C<$class> is
  11657. one of the tokens in the element C<class> attribute)
  11658.  
  11659. =item DESTROY
  11660.  
  11661. Frees the element from memory.
  11662.  
  11663. =item start_tag
  11664.  
  11665. Return the string for the start tag for the element, including 
  11666. the C<< /> >> at the end of an empty element tag
  11667.  
  11668. =item end_tag
  11669.  
  11670. Return the string for the end tag of an element.  For an empty
  11671. element, this returns the empty string ('').
  11672.  
  11673. =item xml_string
  11674.  
  11675. Equivalent to C<< $elt->sprint( 1) >>, returns the string for the entire 
  11676. element, excluding the element's tags (but nested element tags are present)
  11677.  
  11678. =item inner_xml
  11679.  
  11680. Another synonym for xml_string
  11681.  
  11682. =item xml_text 
  11683.  
  11684. Return the text of the element, encoded (and processed by the current 
  11685. C<L<output_filter>> or C<L<output_encoding>> options, without any tag.
  11686.  
  11687. =item set_pretty_print ($style)
  11688.  
  11689. Set the pretty print method, amongst 'C<none>' (default), 'C<nsgmls>', 
  11690. 'C<nice>', 'C<indented>', 'C<record>' and 'C<record_c>'
  11691.  
  11692. pretty_print styles:
  11693.  
  11694. =over 4
  11695.  
  11696. =item none
  11697.  
  11698. the default, no C<\n> is used
  11699.  
  11700. =item nsgmls
  11701.  
  11702. nsgmls style, with C<\n> added within tags
  11703.  
  11704. =item nice
  11705.  
  11706. adds C<\n> wherever possible (NOT SAFE, can lead to invalid XML)
  11707.  
  11708. =item indented
  11709.  
  11710. same as C<nice> plus indents elements (NOT SAFE, can lead to invalid XML) 
  11711.  
  11712. =item record
  11713.  
  11714. table-oriented pretty print, one field per line 
  11715.  
  11716. =item record_c
  11717.  
  11718. table-oriented pretty print, more compact than C<record>, one record per line 
  11719.  
  11720. =back
  11721.  
  11722. =item set_empty_tag_style ($style)
  11723.  
  11724. Set the method to output empty tags, amongst 'C<normal>' (default), 'C<html>',
  11725. and 'C<expand>', 
  11726.  
  11727. C<normal> outputs an empty tag 'C<< <tag/> >>', C<html> adds a space 
  11728. 'C<< <tag /> >>' for elements that can be empty in XHTML and C<expand> outputs
  11729. 'C<< <tag></tag> >>'
  11730.  
  11731. =item set_remove_cdata  ($flag)
  11732.  
  11733. set (or unset) the flag that forces the twig to output CDATA sections as 
  11734. regular (escaped) PCDATA
  11735.  
  11736.  
  11737. =item set_indent ($string)
  11738.  
  11739. Set the indentation for the indented pretty print style (default is 2 spaces)
  11740.  
  11741. =item set_quote ($quote)
  11742.  
  11743. Set the quotes used for attributes. can be 'C<double>' (default) or 'C<single>'
  11744.  
  11745. =item cmp       ($elt)
  11746.  
  11747.   Compare the order of the 2 elements in a twig.
  11748.  
  11749.   C<$a> is the <A>..</A> element, C<$b> is the <B>...</B> element
  11750.   
  11751.   document                        $a->cmp( $b)
  11752.   <A> ... </A> ... <B>  ... </B>     -1
  11753.   <A> ... <B>  ... </B> ... </A>     -1
  11754.   <B> ... </B> ... <A>  ... </A>      1
  11755.   <B> ... <A>  ... </A> ... </B>      1
  11756.    $a == $b                           0
  11757.    $a and $b not in the same tree   undef
  11758.  
  11759. =item before       ($elt)
  11760.  
  11761. Return 1 if C<$elt> starts before the element, 0 otherwise. If the 2 elements 
  11762. are not in the same twig then return C<undef>.
  11763.  
  11764.     if( $a->cmp( $b) == -1) { return 1; } else { return 0; }
  11765.  
  11766. =item after       ($elt)
  11767.  
  11768. Return 1 if $elt starts after the element, 0 otherwise. If the 2 elements 
  11769. are not in the same twig then return C<undef>.
  11770.  
  11771.     if( $a->cmp( $b) == -1) { return 1; } else { return 0; }
  11772.  
  11773. =item other comparison methods
  11774.  
  11775. =over 4
  11776.  
  11777. =item lt
  11778.  
  11779. =item le
  11780.  
  11781. =item gt
  11782.  
  11783. =item ge
  11784.  
  11785. =back
  11786.  
  11787. =item path
  11788.  
  11789. Return the element context in a form similar to XPath's short
  11790. form: 'C</root/tag1/../tag>'
  11791.  
  11792. =item xpath
  11793.  
  11794. Return a unique XPath expression that can be used to find the element
  11795. again. 
  11796.  
  11797. It looks like C</doc/sect[3]/title>: unique elements do not have an index,
  11798. the others do.
  11799.  
  11800. =item private methods
  11801.  
  11802. Low-level methods on the twig:
  11803.  
  11804. =over 4
  11805.  
  11806. =item set_parent        ($parent)
  11807.  
  11808. =item set_first_child   ($first_child)
  11809.  
  11810. =item set_last_child    ($last_child)
  11811.  
  11812. =item set_prev_sibling  ($prev_sibling)
  11813.  
  11814. =item set_next_sibling  ($next_sibling)
  11815.  
  11816. =item set_twig_current
  11817.  
  11818. =item del_twig_current
  11819.  
  11820. =item twig_current
  11821.  
  11822. =item flush
  11823.  
  11824. This method should NOT be used, always flush the twig, not an element.
  11825.  
  11826. =item contains_text
  11827.  
  11828. =back
  11829.  
  11830. Those methods should not be used, unless of course you find some creative 
  11831. and interesting, not to mention useful, ways to do it.
  11832.  
  11833. =back
  11834.  
  11835. =head2 cond
  11836.  
  11837. Most of the navigation functions accept a condition as an optional argument
  11838. The first element (or all elements for C<L<children|children> > or 
  11839. C<L<ancestors|ancestors> >) that passes the condition is returned.
  11840.  
  11841. The condition is a single step of an XPath expression using the XPath subset
  11842. defined by C<L<get_xpath>>. Additional conditions are:
  11843.  
  11844. The condition can be 
  11845.  
  11846. =over 4
  11847.  
  11848. =item #ELT
  11849.  
  11850. return a "real" element (not a PCDATA, CDATA, comment or pi element) 
  11851.  
  11852. =item #TEXT
  11853.  
  11854. return a PCDATA or CDATA element
  11855.  
  11856. =item regular expression
  11857.  
  11858. return an element whose tag matches the regexp. The regexp has to be created 
  11859. with C<qr//> (hence this is available only on perl 5.005 and above)
  11860.  
  11861. =item code reference
  11862.  
  11863. applies the code, passing the current element as argument, if the code returns
  11864. true then the element is returned, if it returns false then the code is applied
  11865. to the next candidate.
  11866.  
  11867. =back
  11868.  
  11869. =head2 XML::Twig::XPath
  11870.  
  11871. XML::Twig implements a subset of XPath through the C<L<get_xpath>> method. 
  11872.  
  11873. If you want to use the whole XPath power, then you can use C<XML::Twig::XPath>
  11874. instead. In this case C<XML::Twig> uses C<XML::XPath> to execute XPath queries.
  11875. You will of course need C<XML::XPath> installed to be able to use C<XML::Twig::XPath>.
  11876.  
  11877. See L<XML::XPath> for more information.
  11878.  
  11879. The methods you can use are:
  11880.  
  11881. =over 4
  11882.  
  11883. =item findnodes              ($path)
  11884.  
  11885. return a list of nodes found by C<$path>.
  11886.  
  11887. =item findnodes_as_string    ($path)
  11888.  
  11889. return the nodes found reproduced as XML. The result is not guaranteed
  11890. to be valid XML though.
  11891.  
  11892. =item findvalue              ($path)
  11893.  
  11894. return the concatenation of the text content of the result nodes
  11895.  
  11896. =back
  11897.  
  11898. In order for C<XML::XPath> to be used as the XPath engine the following methods
  11899. are included in C<XML::Twig>:
  11900.  
  11901. in XML::Twig
  11902.  
  11903. =over 4
  11904.  
  11905. =item getRootNode
  11906.  
  11907. =item getParentNode
  11908.  
  11909. =item getChildNodes 
  11910.  
  11911. =back
  11912.  
  11913. in XML::Twig::Elt
  11914.  
  11915. =over 4
  11916.  
  11917. =item string_value
  11918.  
  11919. =item toString
  11920.  
  11921. =item getName
  11922.  
  11923. =item getRootNode
  11924.  
  11925. =item getNextSibling
  11926.  
  11927. =item getPreviousSibling
  11928.  
  11929. =item isElementNode
  11930.  
  11931. =item isTextNode
  11932.  
  11933. =item isPI
  11934.  
  11935. =item isPINode
  11936.  
  11937. =item isProcessingInstructionNode
  11938.  
  11939. =item isComment
  11940.  
  11941. =item isCommentNode
  11942.  
  11943. =item getTarget 
  11944.  
  11945. =item getChildNodes 
  11946.  
  11947. =item getElementById
  11948.  
  11949. =back
  11950.  
  11951. =head2 XML::Twig::XPath::Elt
  11952.  
  11953. The methods you can use are the same as on C<XML::Twig::XPath> elements:
  11954.  
  11955. =over 4
  11956.  
  11957. =item findnodes              ($path)
  11958.  
  11959. return a list of nodes found by C<$path>.
  11960.  
  11961. =item findnodes_as_string    ($path)
  11962.  
  11963. return the nodes found reproduced as XML. The result is not guaranteed
  11964. to be valid XML though.
  11965.  
  11966. =item findvalue              ($path)
  11967.  
  11968. return the concatenation of the text content of the result nodes
  11969.  
  11970. =back
  11971.  
  11972.  
  11973. =head2 XML::Twig::Entity_list
  11974.  
  11975. =over 4
  11976.  
  11977. =item new
  11978.  
  11979. Create an entity list.
  11980.  
  11981. =item add         ($ent)
  11982.  
  11983. Add an entity to an entity list.
  11984.  
  11985. =item add_new_ent ($name, $val, $sysid, $pubid, $ndata)
  11986.  
  11987. Create a new entity and add it to the entity list
  11988.  
  11989. =item delete     ($ent or $tag).
  11990.  
  11991. Delete an entity (defined by its name or by the Entity object)
  11992. from the list.
  11993.  
  11994. =item print      ($optional_filehandle)
  11995.  
  11996. Print the entity list.
  11997.  
  11998. =item list
  11999.  
  12000. Return the list as an array
  12001.  
  12002. =back
  12003.  
  12004.  
  12005. =head2 XML::Twig::Entity
  12006.  
  12007. =over 4
  12008.  
  12009. =item new        ($name, $val, $sysid, $pubid, $ndata)
  12010.  
  12011. Same arguments as the Entity handler for XML::Parser.
  12012.  
  12013. =item print       ($optional_filehandle)
  12014.  
  12015. Print an entity declaration.
  12016.  
  12017. =item name 
  12018.  
  12019. Return the name of the entity
  12020.  
  12021. =item val  
  12022.  
  12023. Return the value of the entity
  12024.  
  12025. =item sysid
  12026.  
  12027. Return the system id for the entity (for NDATA entities)
  12028.  
  12029. =item pubid
  12030.  
  12031. Return the public id for the entity (for NDATA entities)
  12032.  
  12033. =item ndata
  12034.  
  12035. Return true if the entity is an NDATA entity
  12036.  
  12037. =item text
  12038.  
  12039. Return the entity declaration text.
  12040.  
  12041. =back
  12042.  
  12043.  
  12044. =head1 EXAMPLES
  12045.  
  12046. Additional examples (and a complete tutorial) can be found  on the
  12047. F<XML::Twig PageL<http://www.xmltwig.com/xmltwig/>>
  12048.  
  12049. To figure out what flush does call the following script with an
  12050. XML file and an element name as arguments
  12051.  
  12052.   use XML::Twig;
  12053.  
  12054.   my ($file, $elt)= @ARGV;
  12055.   my $t= XML::Twig->new( twig_handlers => 
  12056.       { $elt => sub {$_[0]->flush; print "\n[flushed here]\n";} });
  12057.   $t->parsefile( $file, ErrorContext => 2);
  12058.   $t->flush;
  12059.   print "\n";
  12060.  
  12061.  
  12062. =head1 NOTES
  12063.  
  12064. =head2 Subclassing XML::Twig
  12065.  
  12066. Useful methods:
  12067.  
  12068. =over 4
  12069.  
  12070. =item elt_class
  12071.  
  12072. In order to subclass C<XML::Twig> you will probably need to subclass also
  12073. C<L<XML::Twig::Elt>>. Use the C<elt_class> option when you create the
  12074. C<XML::Twig> object to get the elements created in a different class
  12075. (which should be a subclass of C<XML::Twig::Elt>.
  12076.  
  12077. =item add_options
  12078.  
  12079. If you inherit C<XML::Twig> new method but want to add more options to it
  12080. you can use this method to prevent XML::Twig to issue warnings for those
  12081. additional options.
  12082.  
  12083. =back
  12084.  
  12085. =head2 DTD Handling
  12086.  
  12087. There are 3 possibilities here.  They are:
  12088.  
  12089. =over 4
  12090.  
  12091. =item No DTD
  12092.  
  12093. No doctype, no DTD information, no entity information, the world is simple...
  12094.  
  12095. =item Internal DTD
  12096.  
  12097. The XML document includes an internal DTD, and maybe entity declarations.
  12098.  
  12099. If you use the load_DTD option when creating the twig the DTD information and
  12100. the entity declarations can be accessed.
  12101.  
  12102. The DTD and the entity declarations will be C<flush>'ed (or C<print>'ed) either
  12103. as is (if they have not been modified) or as reconstructed (poorly, comments 
  12104. are lost, order is not kept, due to it's content this DTD should not be viewed 
  12105. by anyone) if they have been modified. You can also modify them directly by 
  12106. changing the C<< $twig->{twig_doctype}->{internal} >> field (straight from 
  12107. XML::Parser, see the C<Doctype> handler doc)
  12108.  
  12109. =item External DTD
  12110.  
  12111. The XML document includes a reference to an external DTD, and maybe entity 
  12112. declarations.
  12113.  
  12114. If you use the C<load_DTD> when creating the twig the DTD information and the 
  12115. entity declarations can be accessed. The entity declarations will be
  12116. C<flush>'ed (or C<print>'ed) either as is (if they have not been modified) or
  12117. as reconstructed (badly, comments are lost, order is not kept).
  12118.  
  12119. You can change the doctype through the C<< $twig->set_doctype >> method and 
  12120. print the dtd through the C<< $twig->dtd_text >> or C<< $twig->dtd_print >>
  12121.  methods.
  12122.  
  12123. If you need to modify the entity list this is probably the easiest way to do it.
  12124.  
  12125. =back
  12126.  
  12127.  
  12128. =head2 Flush
  12129.  
  12130. If you set handlers and use C<flush>, do not forget to flush the twig one
  12131. last time AFTER the parsing, or you might be missing the end of the document.
  12132.  
  12133. Remember that element handlers are called when the element is CLOSED, so
  12134. if you have handlers for nested elements the inner handlers will be called
  12135. first. It makes it for example trickier than it would seem to number nested
  12136. clauses.
  12137.  
  12138.  
  12139.  
  12140. =head1 BUGS
  12141.  
  12142. =over 4
  12143.  
  12144. =item entity handling
  12145.  
  12146. Due to XML::Parser behaviour, non-base entities in attribute values disappear:
  12147. C<att="val&ent;"> will be turned into C<< att => val >>, unless you use the 
  12148. C<keep_encoding> argument to C<< XML::Twig->new >> 
  12149.  
  12150. =item DTD handling
  12151.  
  12152. The DTD handling methods are quite bugged. No one uses them and
  12153. it seems very difficult to get them to work in all cases, including with 
  12154. several slightly incompatible versions of XML::Parser and of libexpat.
  12155.  
  12156. Basically you can read the DTD, output it back properly, and update entities,
  12157. but not much more.
  12158.  
  12159. So use XML::Twig with standalone documents, or with documents refering to an
  12160. external DTD, but don't expect it to properly parse and even output back the
  12161. DTD.
  12162.  
  12163. =item memory leak
  12164.  
  12165. If you use a lot of twigs you might find that you leak quite a lot of memory
  12166. (about 2Ks per twig). You can use the C<L<dispose|dispose> > method to free 
  12167. that memory after you are done.
  12168.  
  12169. If you create elements the same thing might happen, use the C<L<delete|delete>>
  12170. method to get rid of them.
  12171.  
  12172. Alternatively installing the C<Scalar::Util> (or C<WeakRef>) module on a version 
  12173. of Perl that supports it (>5.6.0) will get rid of the memory leaks automagically.
  12174.  
  12175. =item ID list
  12176.  
  12177. The ID list is NOT updated when elements are cut or deleted.
  12178.  
  12179. =item change_gi
  12180.  
  12181. This method will not function properly if you do:
  12182.  
  12183.      $twig->change_gi( $old1, $new);
  12184.      $twig->change_gi( $old2, $new);
  12185.      $twig->change_gi( $new, $even_newer);
  12186.  
  12187. =item sanity check on XML::Parser method calls
  12188.  
  12189. XML::Twig should really prevent calls to some XML::Parser methods, especially 
  12190. the C<setHandlers> method.
  12191.  
  12192. =item pretty printing
  12193.  
  12194. Pretty printing (at least using the 'C<indented>' style) is hard to get right! 
  12195. Only elements that belong to the document will be properly indented. Printing 
  12196. elements that do not belong to the twig makes it impossible for XML::Twig to 
  12197. figure out their depth, and thus their indentation level.
  12198.  
  12199. Also there is an unavoidable bug when using C<flush> and pretty printing for
  12200. elements with mixed content that start with an embedded element:
  12201.  
  12202.   <elt><b>b</b>toto<b>bold</b></elt>
  12203.  
  12204.   will be output as 
  12205.  
  12206.   <elt>
  12207.     <b>b</b>toto<b>bold</b></elt>
  12208.  
  12209. if you flush the twig when you find the C<< <b> >> element
  12210.   
  12211.  
  12212. =back
  12213.  
  12214. =head1 Globals
  12215.  
  12216. These are the things that can mess up calling code, especially if threaded.
  12217. They might also cause problem under mod_perl. 
  12218.  
  12219. =over 4
  12220.  
  12221. =item Exported constants
  12222.  
  12223. Whether you want them or not you get them! These are subroutines to use
  12224. as constant when creating or testing elements
  12225.  
  12226.   PCDATA  return '#PCDATA'
  12227.   CDATA   return '#CDATA'
  12228.   PI      return '#PI', I had the choice between PROC and PI :--(
  12229.  
  12230. =item Module scoped values: constants
  12231.  
  12232. these should cause no trouble:
  12233.  
  12234.   %base_ent= ( '>' => '>',
  12235.                '<' => '<',
  12236.                '&' => '&',
  12237.                "'" => ''',
  12238.                '"' => '"',
  12239.              );
  12240.   CDATA_START   = "<![CDATA[";
  12241.   CDATA_END     = "]]>";
  12242.   PI_START      = "<?";
  12243.   PI_END        = "?>";
  12244.   COMMENT_START = "<!--";
  12245.   COMMENT_END   = "-->";
  12246.  
  12247. pretty print styles
  12248.  
  12249.   ( $NSGMLS, $NICE, $INDENTED, $INDENTED_C, $WRAPPED, $RECORD1, $RECORD2)= (1..7);
  12250.  
  12251. empty tag output style
  12252.  
  12253.   ( $HTML, $EXPAND)= (1..2);
  12254.  
  12255. =item Module scoped values: might be changed
  12256.  
  12257. Most of these deal with pretty printing, so the worst that can
  12258. happen is probably that XML output does not look right, but is
  12259. still valid and processed identically by XML processors.
  12260.  
  12261. C<$empty_tag_style> can mess up HTML bowsers though and changing C<$ID> 
  12262. would most likely create problems.
  12263.  
  12264.   $pretty=0;           # pretty print style
  12265.   $quote='"';          # quote for attributes
  12266.   $INDENT= '  ';       # indent for indented pretty print
  12267.   $empty_tag_style= 0; # how to display empty tags
  12268.   $ID                  # attribute used as an id ('id' by default)
  12269.  
  12270. =item Module scoped values: definitely changed
  12271.  
  12272. These 2 variables are used to replace tags by an index, thus 
  12273. saving some space when creating a twig. If they really cause
  12274. you too much trouble, let me know, it is probably possible to
  12275. create either a switch or at least a version of XML::Twig that 
  12276. does not perform this optimisation.
  12277.  
  12278.   %gi2index;     # tag => index
  12279.   @index2gi;     # list of tags
  12280.  
  12281. =back
  12282.  
  12283. If you need to manipulate all those values, you can use the following methods on the
  12284. XML::Twig object:
  12285.  
  12286. =over 4
  12287.  
  12288. =item global_state
  12289.  
  12290. Return a hasref with all the global variables used by XML::Twig
  12291.  
  12292. The hash has the following fields:  C<pretty>, C<quote>, C<indent>, 
  12293. C<empty_tag_style>, C<keep_encoding>, C<expand_external_entities>, 
  12294. C<output_filter>, C<output_text_filter>, C<keep_atts_order>
  12295.  
  12296. =item set_global_state ($state)
  12297.  
  12298. Set the global state, C<$state> is a hashref
  12299.  
  12300. =item save_global_state
  12301.  
  12302. Save the current global state
  12303.  
  12304. =item restore_global_state
  12305.  
  12306. Restore the previously saved (using C<Lsave_global_state>> state
  12307.  
  12308. =back
  12309.  
  12310. =head1 TODO 
  12311.  
  12312. =over 4
  12313.  
  12314. =item SAX handlers
  12315.  
  12316. Allowing XML::Twig to work on top of any SAX parser
  12317.  
  12318. =item multiple twigs are not well supported
  12319.  
  12320. A number of twig features are just global at the moment. These include
  12321. the ID list and the "tag pool" (if you use C<change_gi> then you change the tag 
  12322. for ALL twigs).
  12323.  
  12324. A future version will try to support this while trying not to be to
  12325. hard on performance (at least when a single twig is used!).
  12326.  
  12327.  
  12328. =back
  12329.  
  12330.  
  12331. =head1 AUTHOR
  12332.  
  12333. Michel Rodriguez <mirod@xmltwig.com>
  12334.  
  12335. =head1 LICENSE
  12336.  
  12337. This library is free software; you can redistribute it and/or modify
  12338. it under the same terms as Perl itself.
  12339.  
  12340. Bug reports should be sent using:
  12341. F<RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=XML-Twig>>
  12342.  
  12343. Comments can be sent to mirod@xmltwig.com
  12344.  
  12345. The XML::Twig page is at L<http://www.xmltwig.com/xmltwig/>
  12346. It includes the development version of the module, a slightly better version 
  12347. of the documentation, examples, a tutorial and a: 
  12348. F<Processing XML efficiently with Perl and XML::Twig: 
  12349. L<http://www.xmltwig.com/xmltwig/tutorial/index.html>>
  12350.  
  12351. =head1 SEE ALSO
  12352.  
  12353. Complete docs, including a tutorial, examples, an easier to use HTML version of
  12354. the docs, a quick reference card and a FAQ are available at 
  12355. L<http://www.xmltwig.com/xmltwig/>
  12356.  
  12357. L<XML::Parser>, L<XML::Parser::Expat>, L<XML::XPath>, L<Encode>, 
  12358. L<Text::Iconv>, L<Scalar::Utils>
  12359.  
  12360.  
  12361. =head2 Alternative Modules
  12362.  
  12363. XML::Twig is not the only XML::Processing module available on CPAN (far from 
  12364. it!).
  12365.  
  12366. The main alternative I would recommend is L<XML::LibXML>. 
  12367.  
  12368. Here is a quick comparison of the 2 modules:
  12369.  
  12370. XML::LibXML, actually C<libxml2> on which it is based, sticks to the standards,
  12371. and implements a good number of them in a rather strict way: XML, XPath, DOM, 
  12372. RelaxNG, I must be forgetting a couple (XInclude?). It is fast and rather 
  12373. frugal memory-wise.
  12374.  
  12375. XML::Twig is older: when I started writing it XML::Parser/expat was the only 
  12376. game in town. It implements XML and that's about it (plus a subset of XPath, 
  12377. and you can use XML::Twig::XPath if you have XML::XPath installed for full 
  12378. support). It is slower and requires more memory for a full tree than 
  12379. XML::LibXML. On the plus side (yes, there is a plus side!) it lets you process
  12380. a big document in chunks, and thus let you tackle documents that couldn't be 
  12381. loaded in memory by XML::LibXML, and it offers a lot (and I mean a LOT!) of 
  12382. higher-level methods, for everything, from adding structure to "low-level" XML,
  12383. to shortcuts for XHTML conversions and more. It also DWIMs quite a bit, getting
  12384. comments and non-significant whitespaces out of the way but preserving them in 
  12385. the output for example. As it does not stick to the DOM, is also usually leads 
  12386. to shorter code than in XML::LibXML.
  12387.  
  12388. Beyond the pure features of the 2 modules, XML::LibXML seems to be prefered by
  12389. "XML-purists", while XML::Twig seems to be more used by Perl Hackers who have 
  12390. to deal with XML. As you have noted, XML::Twig also comes with quite a lot of 
  12391. docs, but I am sure if you ask for help about XML::LibXML here or on Perlmonks
  12392. you will get answers.
  12393.  
  12394. Note that it is actually quite hard for me to compare the 2 modules: on one hand
  12395. I know XML::Twig inside-out and I can get it to do pretty much anything I need 
  12396. to (or I improve it ;--), while I have a very basic knowledge of XML::LibXML. 
  12397. So feature-wise, I'd rather use XML::Twig ;--). On the other hand, I am 
  12398. painfully aware of some of the deficiencies, potential bugs and plain ugly code
  12399. that lurk in XML::Twig, even though you are unlikely to be affected by them 
  12400. (unless for example you need to change the DTD of a document programatically),
  12401. while I haven't looked much into XML::LibXML so it still looks shinny and clean
  12402. to me.
  12403.  
  12404. That said, ifyou need to process a document that is too big to fit memory
  12405. and XML::Twig is too slow for you, my reluctant advice would be to use "bare"
  12406. XML::Parser.  It won't be as easy to use as XML::Twig: basically with XML::Twig
  12407. you trade some speed (depending on what you do from a factor 3 to... none) 
  12408. for ease-of-use, but it will be easier IMHO than using SAX (albeit not 
  12409. standard), and at this point a LOT faster (see the last test in
  12410. L<http://www.xmltwig.com/article/simple_benchmark/>).
  12411.  
  12412. =cut
  12413.  
  12414.  
  12415.